modern: add to core to eventually take over as the new parser. same as code-factor's version except i added support for :foo words.
Doug Coleman
parent
507957eae3
commit
5e8244c47e
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,370 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs classes.mixin combinators
|
||||||
|
combinators.short-circuit definitions effects effects.parser fry
|
||||||
|
graphs io.pathnames kernel lexer locals math math.statistics
|
||||||
|
memoize modern multiline parser quotations sequences
|
||||||
|
sequences.extras sets splitting strings unicode words ;
|
||||||
|
IN: modern.compiler
|
||||||
|
|
||||||
|
: vocab>core2-path ( vocab -- path )
|
||||||
|
".private" ?tail drop
|
||||||
|
"." split "/" join
|
||||||
|
[ "resource:core2/" prepend-path ]
|
||||||
|
[ file-name ".factor" append append-path ] bi ;
|
||||||
|
|
||||||
|
: filter-using ( using -- using' )
|
||||||
|
{ "accessors" "threads.private" "threads" } diff ;
|
||||||
|
|
||||||
|
<<
|
||||||
|
SYNTAX: STRING-DISPATCH:
|
||||||
|
[
|
||||||
|
scan-new-word scan-effect
|
||||||
|
H{ } clone over [ in>> but-last ] [ out>> ] bi <effect>
|
||||||
|
'[ _ ?at [ throw ] unless _ call-effect ]
|
||||||
|
swap
|
||||||
|
] with-definition define-declared ;
|
||||||
|
|
||||||
|
SYNTAX: STRING-M:
|
||||||
|
[
|
||||||
|
scan-token scan-word parse-definition
|
||||||
|
over changed-definition
|
||||||
|
swap def>> first swapd set-at
|
||||||
|
] with-definition ;
|
||||||
|
>>
|
||||||
|
|
||||||
|
|
||||||
|
TUPLE: holder literal ;
|
||||||
|
TUPLE: comment' < holder ;
|
||||||
|
TUPLE: using' < holder ;
|
||||||
|
TUPLE: use' < holder ;
|
||||||
|
TUPLE: in' < holder ;
|
||||||
|
TUPLE: qualified-with' < holder ;
|
||||||
|
TUPLE: qualified' < holder ;
|
||||||
|
TUPLE: script' < holder ;
|
||||||
|
TUPLE: m' < holder ;
|
||||||
|
TUPLE: instance' < holder ;
|
||||||
|
TUPLE: word' < holder ;
|
||||||
|
TUPLE: generic' < holder ;
|
||||||
|
TUPLE: generic#' < holder ;
|
||||||
|
TUPLE: hook' < holder ;
|
||||||
|
TUPLE: math' < holder ;
|
||||||
|
TUPLE: constant' < holder ;
|
||||||
|
TUPLE: c' < holder ;
|
||||||
|
TUPLE: initialize' < holder ;
|
||||||
|
TUPLE: startup-hook' < holder ;
|
||||||
|
TUPLE: shutdown-hook' < holder ;
|
||||||
|
TUPLE: primitive' < holder ;
|
||||||
|
TUPLE: defer' < holder ;
|
||||||
|
TUPLE: symbols' < holder ;
|
||||||
|
TUPLE: symbol' < holder ;
|
||||||
|
TUPLE: slot' < holder ;
|
||||||
|
TUPLE: mixin' < holder ;
|
||||||
|
TUPLE: singletons' < holder ;
|
||||||
|
TUPLE: singleton' < holder ;
|
||||||
|
TUPLE: tuple' < holder ;
|
||||||
|
TUPLE: error' < holder ;
|
||||||
|
TUPLE: builtin' < holder ;
|
||||||
|
TUPLE: predicate' < holder ;
|
||||||
|
TUPLE: union' < holder ;
|
||||||
|
|
||||||
|
! generated definitions
|
||||||
|
TUPLE: define' holder name ;
|
||||||
|
TUPLE: generate-accessor' < define' ;
|
||||||
|
TUPLE: generate-predicate' < define' ;
|
||||||
|
|
||||||
|
: make-holder ( literal class -- obj )
|
||||||
|
new
|
||||||
|
swap >>literal ; inline
|
||||||
|
|
||||||
|
GENERIC: split-decorators ( seq -- base left right )
|
||||||
|
M: compound-literal split-decorators
|
||||||
|
sequence>>
|
||||||
|
[ decorator-literal? not ] partition
|
||||||
|
[ first ] dip
|
||||||
|
[ left-decorator-literal? ] partition ;
|
||||||
|
M: object split-decorators f f ;
|
||||||
|
|
||||||
|
! GENERIC: apply-decorator ( base decorator -- )
|
||||||
|
! : apply-decorators ( obj seq -- obj ) ;
|
||||||
|
|
||||||
|
GENERIC: base-literal ( obj -- obj )
|
||||||
|
M: compound-literal base-literal
|
||||||
|
sequence>> [ decorator-literal? not ] find nip ;
|
||||||
|
M: object base-literal ;
|
||||||
|
|
||||||
|
|
||||||
|
GENERIC: literal>tag ( class -- string/f )
|
||||||
|
M: line-comment-literal literal>tag drop f ;
|
||||||
|
M: uppercase-colon-literal literal>tag
|
||||||
|
tag>> [ "word" ] [ >lower ] if-empty ;
|
||||||
|
M: compound-literal literal>tag
|
||||||
|
base-literal literal>tag ;
|
||||||
|
|
||||||
|
: literal>holder ( literal -- obj )
|
||||||
|
[ ] [
|
||||||
|
literal>tag [ "'" append "modern.compiler" lookup-word ]
|
||||||
|
[ \ comment' ] if*
|
||||||
|
] bi
|
||||||
|
'[ _ make-holder ] call( obj -- obj ) ;
|
||||||
|
|
||||||
|
: literals>holders ( literals -- holders )
|
||||||
|
[ literal>holder ] map ;
|
||||||
|
|
||||||
|
GENERIC: holder>definitions' ( literal -- assoc )
|
||||||
|
M: comment' holder>definitions' drop f ;
|
||||||
|
M: using' holder>definitions' drop f ;
|
||||||
|
M: use' holder>definitions' drop f ;
|
||||||
|
M: in' holder>definitions' drop f ;
|
||||||
|
M: qualified-with' holder>definitions' drop f ;
|
||||||
|
M: qualified' holder>definitions' drop f ;
|
||||||
|
M: script' holder>definitions' drop f ;
|
||||||
|
M: m' holder>definitions' drop f ;
|
||||||
|
M: instance' holder>definitions' drop f ;
|
||||||
|
|
||||||
|
! Single words
|
||||||
|
M: word' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: generic' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: generic#' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: hook' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: math' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: constant' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: c' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: initialize' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: startup-hook' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: shutdown-hook' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: primitive' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
M: defer' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> first tag>> define' boa ;
|
||||||
|
|
||||||
|
! Multiple words
|
||||||
|
M: symbols' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> [ tag>> ] map [ define' boa ] with map ;
|
||||||
|
M: symbol' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> [ tag>> ] map [ define' boa ] with map ;
|
||||||
|
M: slot' holder>definitions'
|
||||||
|
dup literal>> base-literal payload>> [ tag>> ] map
|
||||||
|
[ generate-accessor' boa ] with map ;
|
||||||
|
|
||||||
|
! these also make class predicate? words
|
||||||
|
|
||||||
|
GENERIC: slot-accessor-name ( obj -- string )
|
||||||
|
M: single-matched-literal slot-accessor-name
|
||||||
|
payload>> first tag>> ">>" append ;
|
||||||
|
M: tag-literal slot-accessor-name tag>> ">>" append ;
|
||||||
|
|
||||||
|
M: tuple' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> define' boa ]
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> "?" append generate-predicate' boa ]
|
||||||
|
[
|
||||||
|
dup literal>> base-literal payload>> rest
|
||||||
|
[ slot-accessor-name generate-accessor' boa ] with map
|
||||||
|
] tri [ 2array ] dip append ;
|
||||||
|
|
||||||
|
M: error' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> define' boa ]
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> "?" append generate-predicate' boa ]
|
||||||
|
[
|
||||||
|
dup literal>> base-literal payload>> rest
|
||||||
|
[ slot-accessor-name generate-accessor' boa ] with map
|
||||||
|
] tri [ 2array ] dip append ;
|
||||||
|
|
||||||
|
M: builtin' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> define' boa ]
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> "?" append generate-predicate' boa ] bi 2array ;
|
||||||
|
M: predicate' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> define' boa ]
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> "?" append generate-predicate' boa ] bi 2array ;
|
||||||
|
M: union' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> define' boa ]
|
||||||
|
[ dup literal>> base-literal payload>> first tag>> "?" append generate-predicate' boa ] bi 2array ;
|
||||||
|
|
||||||
|
! Multiple and class predicates
|
||||||
|
M: mixin' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> [ tag>> ] map [ define' boa ] with map ]
|
||||||
|
[ dup literal>> base-literal payload>> [ tag>> "?" append ] map [ generate-predicate' boa ] with map ] bi append ;
|
||||||
|
|
||||||
|
M: singletons' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> [ tag>> ] map [ define' boa ] with map ]
|
||||||
|
[ dup literal>> base-literal payload>> [ tag>> "?" append ] map [ generate-predicate' boa ] with map ] bi append ;
|
||||||
|
|
||||||
|
M: singleton' holder>definitions'
|
||||||
|
[ dup literal>> base-literal payload>> [ tag>> ] map [ define' boa ] with map ]
|
||||||
|
[ dup literal>> base-literal payload>> [ tag>> "?" append ] map [ generate-predicate' boa ] with map ] bi append ;
|
||||||
|
|
||||||
|
: holder>definitions ( obj -- seq )
|
||||||
|
holder>definitions' dup sequence? [ 1array ] unless ;
|
||||||
|
|
||||||
|
: holders>definitions ( holders -- seq )
|
||||||
|
[ holder>definitions ] map concat ;
|
||||||
|
|
||||||
|
|
||||||
|
: holders>using ( holders -- using )
|
||||||
|
[ { [ using'? ] [ use'? ] } 1|| ] filter
|
||||||
|
[ literal>> payload>> [ tag>> ] map ] map concat ;
|
||||||
|
|
||||||
|
: holders>in ( holders -- using )
|
||||||
|
[ in'? ] filter
|
||||||
|
[ literal>> payload>> [ tag>> ] map ] map concat ;
|
||||||
|
|
||||||
|
GENERIC: handle-colon-tag ( seq tag -- obj )
|
||||||
|
GENERIC: handle-paren-tag ( seq tag -- obj )
|
||||||
|
! M: f handle-paren-tag drop <effect> ;
|
||||||
|
GENERIC: handle-brace-tag ( seq tag -- obj )
|
||||||
|
GENERIC: handle-bracket-tag ( seq tag -- obj )
|
||||||
|
GENERIC: handle-string-tag ( seq tag -- obj )
|
||||||
|
|
||||||
|
ERROR: word-not-found word ;
|
||||||
|
: lookup-in-namespace ( key namespace -- obj/f )
|
||||||
|
?at [
|
||||||
|
] [
|
||||||
|
word-not-found
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
GENERIC# lookup-literal 1 ( literal namespace -- obj )
|
||||||
|
|
||||||
|
M: tag-literal lookup-literal
|
||||||
|
[ tag>> ] dip lookup-in-namespace ;
|
||||||
|
|
||||||
|
: lookup-sequence ( seq namespace -- obj )
|
||||||
|
'[ _ lookup-literal ] map ;
|
||||||
|
|
||||||
|
ERROR: unknown-tag tag ;
|
||||||
|
|
||||||
|
ERROR: unknown-single-matched-delimiter sequence tag ch ;
|
||||||
|
M: single-matched-literal lookup-literal
|
||||||
|
[ [ payload>> ] dip lookup-sequence ]
|
||||||
|
[ [ tag>> ] dip over empty? [ 2drop f ] [ lookup-literal ] if ]
|
||||||
|
[ drop delimiter>> ] 2tri
|
||||||
|
{
|
||||||
|
{ "(" [ handle-paren-tag ] }
|
||||||
|
{ "{" [ handle-brace-tag ] }
|
||||||
|
{ "[" [ handle-bracket-tag ] }
|
||||||
|
{ ":" [ handle-colon-tag ] }
|
||||||
|
{ "\"" [ handle-string-tag ] }
|
||||||
|
[ unknown-single-matched-delimiter ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
|
||||||
|
GENERIC: definition>quotation ( namespace name definition -- quot )
|
||||||
|
M: define' definition>quotation
|
||||||
|
holder>> definition>quotation
|
||||||
|
;
|
||||||
|
|
||||||
|
|
||||||
|
! Done by update-classes
|
||||||
|
M: generate-predicate' definition>quotation 3drop f ;
|
||||||
|
|
||||||
|
|
||||||
|
GENERIC: stack-effect? ( obj -- ? )
|
||||||
|
M: single-matched-literal stack-effect? { [ tag>> ] [ delimiter>> "(" = ] } 1&& ;
|
||||||
|
M: object stack-effect? drop f ;
|
||||||
|
|
||||||
|
ERROR: word-expects-stack-effect ;
|
||||||
|
: ensure-stack-effect ( obj -- ? )
|
||||||
|
dup stack-effect? [ word-expects-stack-effect ] unless ;
|
||||||
|
|
||||||
|
ERROR: word-expects-name-effect-body payload ;
|
||||||
|
: name-effect-body ( payload -- name effect body )
|
||||||
|
payload>> dup length 2 < [ word-expects-name-effect-body ] when
|
||||||
|
[ first2 ensure-stack-effect ] [ 2 tail ] bi ;
|
||||||
|
|
||||||
|
: body>quotation ( body namespace -- quot )
|
||||||
|
2drop [ ]
|
||||||
|
;
|
||||||
|
|
||||||
|
M:: word' definition>quotation ( namespace name definition -- quot )
|
||||||
|
definition literal>> base-literal
|
||||||
|
name-effect-body :> ( name' effect body )
|
||||||
|
name
|
||||||
|
body namespace body>quotation
|
||||||
|
effect namespace lookup-literal
|
||||||
|
'[ _ _ _ define-declared ] ;
|
||||||
|
|
||||||
|
M: mixin' definition>quotation
|
||||||
|
! literal>> base-literal payload>> first tag>> >string
|
||||||
|
drop nip '[ _ define-mixin-class ] ;
|
||||||
|
|
||||||
|
M: object definition>quotation
|
||||||
|
3drop [ ] ;
|
||||||
|
|
||||||
|
TUPLE: manifest2 name literals holders definitions definition-assoc namespaces ;
|
||||||
|
|
||||||
|
: <manifest2> ( name literals holders definitions -- manifest2 )
|
||||||
|
manifest2 new
|
||||||
|
swap >>definitions
|
||||||
|
dup definitions>> [ [ name>> ] keep ] { } map>assoc >>definition-assoc
|
||||||
|
swap >>holders
|
||||||
|
swap >>literals
|
||||||
|
swap ".private" ?tail drop >>name ; inline
|
||||||
|
|
||||||
|
: manifest>scoped-words ( manifest -- seq )
|
||||||
|
[ name>> ] [ definition-assoc>> keys ] bi
|
||||||
|
[ ":" glue ] with map ;
|
||||||
|
|
||||||
|
: manifest>own-namespace ( manifest -- namespace )
|
||||||
|
[ definition-assoc>> keys ] [ manifest>scoped-words [ 1array ] map ] bi
|
||||||
|
zip ;
|
||||||
|
|
||||||
|
: manifest>using ( manifest -- seq )
|
||||||
|
holders>> holders>using ;
|
||||||
|
|
||||||
|
DEFER: load-modern
|
||||||
|
: manifest>combined-namespace ( manifest -- namespaces )
|
||||||
|
[ manifest>using [ load-modern manifest>own-namespace ] map sift members H{ } clone [ assoc-union ] reduce ]
|
||||||
|
[ manifest>own-namespace ] bi assoc-union ;
|
||||||
|
|
||||||
|
: manifest>quotation ( manifest -- quot )
|
||||||
|
[ manifest>combined-namespace ] [ definitions>> ] bi
|
||||||
|
[ [ name>> ] [ ] bi definition>quotation ] with { } map-as concat ;
|
||||||
|
|
||||||
|
GENERIC: add-predicates ( obj -- seq )
|
||||||
|
M: string add-predicates dup "?" append 2array ;
|
||||||
|
M: sequence add-predicates [ add-predicates ] map concat ;
|
||||||
|
|
||||||
|
|
||||||
|
: manifest>definitions ( manifest -- namespace )
|
||||||
|
[ name>> ]
|
||||||
|
[ definitions>> [ name>> ] map ] bi
|
||||||
|
[ ":" glue ] with map ;
|
||||||
|
|
||||||
|
: literals>manifest ( name/f literals -- manifest )
|
||||||
|
dup literals>holders
|
||||||
|
dup holders>definitions <manifest2> ;
|
||||||
|
|
||||||
|
: string>manifest ( string -- manifest )
|
||||||
|
string>literals f swap literals>manifest ;
|
||||||
|
|
||||||
|
MEMO: load-modern ( name -- literals )
|
||||||
|
dup vocab>core2-path path>literals
|
||||||
|
literals>manifest ;
|
||||||
|
|
||||||
|
: load-modern-closure ( vocab -- manifests )
|
||||||
|
\ load-modern reset-memoized
|
||||||
|
load-modern [ holders>using [ load-modern ] map ] closure ;
|
||||||
|
|
||||||
|
|
||||||
|
/*
|
||||||
|
"sequences" load-modern
|
||||||
|
[ holder>definitions ] map sift
|
||||||
|
[ dup array? [ [ name>> ] map ] [ name>> ] if ] map flatten
|
||||||
|
describe
|
||||||
|
|
||||||
|
|
||||||
|
clear
|
||||||
|
"sequences" load-modern
|
||||||
|
definitions>> [ define'? ] filter
|
||||||
|
[ holder>> word'? ] filter
|
||||||
|
first
|
||||||
|
*/
|
||||||
|
|
@ -0,0 +1,98 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors kernel modern sequences strings tools.test ;
|
||||||
|
IN: modern.tests
|
||||||
|
|
||||||
|
{ 0 } [ "" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "a" string>literals length ] unit-test
|
||||||
|
{ 1 } [ " a" string>literals length ] unit-test
|
||||||
|
{ 1 } [ " a " string>literals length ] unit-test
|
||||||
|
{ 3 } [ "a b c" string>literals length ] unit-test
|
||||||
|
|
||||||
|
{ 1 } [ "`abc" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "`abc `cba" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "\"abc\" \"cba\"" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "[[abc]] [[cba]]" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "{{abc}} {{cba}}" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "((abc)) ((cba))" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "[=[abc]=] [=[cba]=]" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "{={abc}=} {={cba}=}" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "(=(abc)=) (=(cba)=)" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "[==[abc]==] [==[cba]==]" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "{=={abc}==} {=={cba}==}" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "(==(abc)==) (==(cba)==)" string>literals length ] unit-test
|
||||||
|
|
||||||
|
{ 1 } [ "hex`abc" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex`abc hex`cba" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex\"abc\" hex\"cba\"" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex[[abc]] hex[[cba]]" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex{{abc}} hex{{cba}}" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex((abc)) hex((cba))" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex[=[abc]=] hex[=[cba]=]" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex{={abc}=} hex{={cba}=}" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex(=(abc)=) hex(=(cba)=)" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex[==[abc]==] hex[==[cba]==]" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex{=={abc}==} hex{=={cba}==}" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "hex(==(abc)==) hex(==(cba)==)" string>literals length ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
{ 1 } [ "[ ]" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc[ ]" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc[ 1 ]" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc[ 1 abc]" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "{ }" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc{ }" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc{ 1 }" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc{ 1 abc}" string>literals length ] unit-test
|
||||||
|
|
||||||
|
{ 1 } [ "( )" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc( )" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc( 1 )" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "abc( 1 abc)" string>literals length ] unit-test
|
||||||
|
|
||||||
|
[ "A{ B}" string>literals ] must-fail
|
||||||
|
[ "A( B)" string>literals ] must-fail
|
||||||
|
[ "A[ B]" string>literals ] must-fail
|
||||||
|
[ "A: B;" string>literals ] must-fail
|
||||||
|
[ "A: AA;" string>literals ] must-fail
|
||||||
|
[ "A: B{ C} A;" string>literals ] must-fail
|
||||||
|
|
||||||
|
{ 1 } [ "!omg" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "! omg" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "![[omg]]" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "![[
|
||||||
|
omg]]" string>literals length
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
{ 1 } [ "\\ a" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "\\ \\" string>literals length ] unit-test
|
||||||
|
{ 1 } [ " \\ abcd " string>literals length ] unit-test
|
||||||
|
|
||||||
|
{ "omg" } [ "!omg" string>literals first payload>> >string ] unit-test
|
||||||
|
|
||||||
|
! Comment character should be #, and should not be allowed in word names
|
||||||
|
! For now, we have exclamation as comment character and words
|
||||||
|
! like suffix! which aren't allowed to start comments
|
||||||
|
{ 2 } [ "a!omg lol" string>literals length ] unit-test
|
||||||
|
{ 3 } [ "a! omg lol" string>literals length ] unit-test
|
||||||
|
{ 2 } [ "a![[omg]] lol" string>literals length ] unit-test
|
||||||
|
|
||||||
|
{ t } [ "[ ][ ][ ]" string>literals length 1 = ] unit-test
|
||||||
|
{ t } [ "[ ][ ][ ]" string>literals first compound-literal? ] unit-test
|
||||||
|
{ t } [ "[ ][ ][ ]" string>literals first sequence>> length 3 = ] unit-test
|
||||||
|
|
||||||
|
! This is broken.
|
||||||
|
! hex[[abc]] -> hex#[[abc]] ! commented out hex literal!
|
||||||
|
! $hex[[abc${0}]] ! interpolate
|
||||||
|
! { 2 } [ "a![[
|
||||||
|
! omg]] lol" string>literals length
|
||||||
|
! ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
{ 1 } [ "a@ b@ hi @c @d" string>literals length ] unit-test
|
||||||
|
|
||||||
|
{ 1 } [ "{ 1 }@ { 2 }@ hi @{ 3 } @{ 4 }" string>literals length ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
{ 1 } [ ":foo" string>literals length ] unit-test
|
||||||
|
{ 1 } [ "( :integer )" string>literals length ] unit-test
|
||||||
|
|
@ -0,0 +1,469 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs assocs.extras combinators
|
||||||
|
combinators.short-circuit constructors continuations fry
|
||||||
|
io.encodings.utf8 io.files kernel locals macros make math
|
||||||
|
math.order modern.paths modern.slices multiline namespaces
|
||||||
|
quotations sequences sequences.extras splitting
|
||||||
|
splitting.monotonic strings unicode ;
|
||||||
|
IN: modern
|
||||||
|
|
||||||
|
<<
|
||||||
|
! Base rules, everything should have a generator macro
|
||||||
|
TUPLE: lexer generator ;
|
||||||
|
|
||||||
|
! Declarative rules, add more!
|
||||||
|
TUPLE: tag-lexer < lexer ; ! default, if nothing else matches, add one with regexp for c-style names etc
|
||||||
|
TUPLE: dquote-lexer < lexer delimiter escape ignore-whitespace? ; ! ``close`` slot someday to allow ` '
|
||||||
|
TUPLE: matched-lexer < lexer delimiter double-char ; ! ``close`` slot someday, to allow `` ''
|
||||||
|
TUPLE: backtick-lexer < lexer delimiter ;
|
||||||
|
TUPLE: backslash-lexer < lexer delimiter payload-exception? ; ! payload-exception is \n words
|
||||||
|
TUPLE: line-comment-lexer < lexer delimiter word-name-exception? ; ! escape-newline-exception? (like C)
|
||||||
|
TUPLE: colon-lexer < lexer delimiter ;
|
||||||
|
TUPLE: semicolon-lexer < lexer delimiter ; ! ; inline foldable
|
||||||
|
TUPLE: whitespace-lexer < lexer delimiter ; ! \s \r \n \t?
|
||||||
|
TUPLE: terminator-lexer < lexer delimiter ;
|
||||||
|
TUPLE: decorator-lexer < lexer delimiter ;
|
||||||
|
|
||||||
|
! Base lexer result
|
||||||
|
TUPLE: literal underlying seq lexer left-decorators right-decorators ;
|
||||||
|
TUPLE: tag-literal < literal tag ;
|
||||||
|
TUPLE: matched-literal < tag-literal delimiter payload closing-tag ;
|
||||||
|
TUPLE: delimited-literal < tag-literal delimiter payload ;
|
||||||
|
TUPLE: decorator-literal < literal delimiter payload ;
|
||||||
|
|
||||||
|
TUPLE: dquote-literal < delimited-literal ;
|
||||||
|
TUPLE: single-matched-literal < matched-literal ;
|
||||||
|
TUPLE: double-matched-literal < matched-literal ;
|
||||||
|
TUPLE: uppercase-colon-literal < single-matched-literal ;
|
||||||
|
TUPLE: lowercase-colon-literal < delimited-literal ;
|
||||||
|
! TUPLE: standalone-colon-literal < delimited-literal ; ! :foo
|
||||||
|
TUPLE: backtick-literal < delimited-literal ;
|
||||||
|
TUPLE: backslash-literal < delimited-literal ;
|
||||||
|
TUPLE: semicolon-literal < delimited-literal ;
|
||||||
|
TUPLE: line-comment-literal < delimited-literal ;
|
||||||
|
TUPLE: terminator-literal < tag-literal ;
|
||||||
|
TUPLE: whitespace-literal < tag-literal ;
|
||||||
|
|
||||||
|
TUPLE: left-decorator-literal < decorator-literal ;
|
||||||
|
TUPLE: right-decorator-literal < decorator-literal ;
|
||||||
|
|
||||||
|
TUPLE: compound-sequence-literal sequence ;
|
||||||
|
CONSTRUCTOR: <compound-sequence-literal> compound-sequence-literal ( sequence -- obj ) ;
|
||||||
|
>>
|
||||||
|
|
||||||
|
GENERIC: lexed-underlying ( obj -- slice )
|
||||||
|
M: f lexed-underlying ;
|
||||||
|
M: object lexed-underlying underlying>> ;
|
||||||
|
M: slice lexed-underlying ;
|
||||||
|
|
||||||
|
TUPLE: compound-literal sequence ;
|
||||||
|
CONSTRUCTOR: <compound-literal> compound-literal ( sequence -- obj ) ;
|
||||||
|
|
||||||
|
! Ensure that we only have one decorated thing in a compound-literal
|
||||||
|
ERROR: bad-compound-literal seq decorators words ;
|
||||||
|
: check-compound-literal ( seq -- seq ) ;
|
||||||
|
|
||||||
|
GENERIC: make-compound-literals ( seq -- seq' )
|
||||||
|
M: object make-compound-literals ;
|
||||||
|
M: array make-compound-literals
|
||||||
|
[
|
||||||
|
{
|
||||||
|
[ [ lexed-underlying ] bi@ slices-touch? ]
|
||||||
|
[ [ ] [ left-decorator-literal? ] bi* and ]
|
||||||
|
[ [ right-decorator-literal? ] [ ] bi* and ]
|
||||||
|
} 2||
|
||||||
|
] monotonic-split
|
||||||
|
[ dup length 1 > [ <compound-literal> ] [ first ] if ] map ;
|
||||||
|
|
||||||
|
! We have empty decorators, just the @ right here
|
||||||
|
! wrap the decorated object in the payload slot
|
||||||
|
GENERIC: collapse-decorators ( seq -- seq' )
|
||||||
|
M: object collapse-decorators ;
|
||||||
|
M: array collapse-decorators
|
||||||
|
[
|
||||||
|
{
|
||||||
|
[ [ left-decorator-literal? ] [ ] bi* and ]
|
||||||
|
[ [ ] [ right-decorator-literal? ] bi* and ]
|
||||||
|
} 2||
|
||||||
|
] monotonic-split
|
||||||
|
[
|
||||||
|
dup length 1 > [
|
||||||
|
first2
|
||||||
|
2dup [ left-decorator-literal? ] [ ] bi* and [
|
||||||
|
>>payload
|
||||||
|
] [
|
||||||
|
[ payload<< ] keep
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
first
|
||||||
|
] if
|
||||||
|
] map ;
|
||||||
|
|
||||||
|
: split-double-dash ( seq -- seqs )
|
||||||
|
dup [ { [ tag-literal? ] [ tag>> "--" = ] } 1&& ] split-when
|
||||||
|
dup length 1 > [
|
||||||
|
nip <compound-sequence-literal>
|
||||||
|
] [
|
||||||
|
drop
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: postprocess-lexed ( seq -- seq' )
|
||||||
|
collapse-decorators make-compound-literals ;
|
||||||
|
|
||||||
|
|
||||||
|
ERROR: whitespace-expected-after n string ch ;
|
||||||
|
ERROR: expected-more-tokens n string expected ;
|
||||||
|
ERROR: string-expected-got-eof n string ;
|
||||||
|
|
||||||
|
:: make-tag-literal ( tag -- literal )
|
||||||
|
tag-literal new
|
||||||
|
tag >string >>tag
|
||||||
|
tag >>underlying
|
||||||
|
tag 1array >>seq ; inline
|
||||||
|
|
||||||
|
:: make-tag-class-literal ( tag class -- literal )
|
||||||
|
class new
|
||||||
|
tag >string >>tag
|
||||||
|
tag >>underlying
|
||||||
|
tag 1array >>seq ; inline
|
||||||
|
|
||||||
|
:: make-tag-payload-literal ( payload last tag class -- literal )
|
||||||
|
class new
|
||||||
|
tag >string >>tag
|
||||||
|
payload >string >>payload
|
||||||
|
tag last [ dup tag-literal? [ lexed-underlying ] when ] bi@ ?span-slices >>underlying
|
||||||
|
tag payload 2array >>seq ; inline
|
||||||
|
|
||||||
|
:: make-delimited-literal ( payload last tag delimiter class -- literal )
|
||||||
|
class new
|
||||||
|
tag >string >>tag
|
||||||
|
payload dup slice? [ >string ] when >>payload
|
||||||
|
tag last [ dup tag-literal? [ lexed-underlying ] when ] bi@ ?span-slices >>underlying
|
||||||
|
delimiter >string >>delimiter
|
||||||
|
tag delimiter payload 3array >>seq ; inline
|
||||||
|
|
||||||
|
ERROR: mismatched-closing opening closing ;
|
||||||
|
:: make-matched-literal ( payload closing tag opening-delimiter class -- literal )
|
||||||
|
class new
|
||||||
|
tag >string >>tag
|
||||||
|
payload postprocess-lexed opening-delimiter "\"" = [ split-double-dash ] unless >>payload
|
||||||
|
tag closing [ dup tag-literal? [ lexed-underlying ] when ] bi@ ?span-slices >>underlying
|
||||||
|
opening-delimiter >string >>delimiter
|
||||||
|
dup single-matched-literal? [
|
||||||
|
closing tag>> length 1 > [
|
||||||
|
tag opening-delimiter append
|
||||||
|
matching-delimiter-string closing tag>> sequence= [ opening-delimiter closing tag>> mismatched-closing ] unless
|
||||||
|
] when
|
||||||
|
closing tag>> >>closing-tag
|
||||||
|
] when
|
||||||
|
tag opening-delimiter payload closing 4array >>seq ; inline
|
||||||
|
|
||||||
|
:: make-decorator-literal ( payload delimiter class -- literal )
|
||||||
|
class new
|
||||||
|
delimiter >>delimiter
|
||||||
|
payload >>payload
|
||||||
|
payload delimiter [ lexed-underlying ] bi@ ?span-slices >>underlying
|
||||||
|
class left-decorator-literal = [
|
||||||
|
delimiter payload 2array
|
||||||
|
] [
|
||||||
|
payload delimiter 2array
|
||||||
|
] if >>seq ; inline
|
||||||
|
|
||||||
|
:: make-decorator-sentinel ( delimiter left? -- literal )
|
||||||
|
left? left-decorator-literal right-decorator-literal ? new
|
||||||
|
delimiter >>delimiter
|
||||||
|
delimiter 1array >>seq
|
||||||
|
delimiter >>underlying ; inline
|
||||||
|
|
||||||
|
ERROR: long-opening-mismatch tag open n string ch ;
|
||||||
|
|
||||||
|
! (( )) [[ ]] {{ }}
|
||||||
|
MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string seq ) )
|
||||||
|
open-ch dup matching-delimiter {
|
||||||
|
[ drop 2 swap <string> ]
|
||||||
|
[ drop 1string ]
|
||||||
|
[ nip 2 swap <string> ]
|
||||||
|
} 2cleave :> ( openstr2 openstr1 closestr2 )
|
||||||
|
[| n string tag! ch |
|
||||||
|
ch {
|
||||||
|
{ CHAR: = [
|
||||||
|
n string openstr1 slice-til-separator-inclusive [ -1 modify-from ] dip :> ( n' string' opening ch )
|
||||||
|
ch open-ch = [ tag openstr2 n string ch long-opening-mismatch ] unless
|
||||||
|
opening matching-delimiter-string :> needle
|
||||||
|
|
||||||
|
n' string' needle slice-til-string :> ( n'' string'' payload closing )
|
||||||
|
n'' string
|
||||||
|
payload closing tag opening double-matched-literal make-matched-literal
|
||||||
|
] }
|
||||||
|
{ open-ch [
|
||||||
|
tag 1 cut-slice* swap tag! 1 modify-to :> opening
|
||||||
|
n 1 + string closestr2 slice-til-string :> ( n' string' payload closing )
|
||||||
|
n' string
|
||||||
|
payload closing tag opening double-matched-literal make-matched-literal
|
||||||
|
] }
|
||||||
|
[ [ tag openstr2 n string ] dip long-opening-mismatch ]
|
||||||
|
} case
|
||||||
|
] ;
|
||||||
|
|
||||||
|
: read-double-matched-paren ( 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 ;
|
||||||
|
|
||||||
|
DEFER: lex
|
||||||
|
DEFER: lex-factor
|
||||||
|
ERROR: lex-expected-but-got-eof n string expected ;
|
||||||
|
! For implementing [ { (
|
||||||
|
: lex-until ( n string tags -- n' string payload closing )
|
||||||
|
pick [
|
||||||
|
3dup '[
|
||||||
|
[
|
||||||
|
lex-factor dup , [
|
||||||
|
dup tag-literal? [
|
||||||
|
! } gets a chance, but then also full seq { } after recursion...
|
||||||
|
[ _ ] dip underlying>> '[ _ sequence= ] any? not
|
||||||
|
] [
|
||||||
|
drop t ! loop again?
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
_ _ _ lex-expected-but-got-eof
|
||||||
|
] if*
|
||||||
|
] loop
|
||||||
|
] { } make unclip-last
|
||||||
|
] [
|
||||||
|
lex-expected-but-got-eof
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
|
||||||
|
ch dup matching-delimiter {
|
||||||
|
[ drop "=" swap prefix ]
|
||||||
|
[ nip 1string ]
|
||||||
|
} 2cleave :> ( openstreq closestr1 ) ! [= ]
|
||||||
|
[| n string tag |
|
||||||
|
n string tag
|
||||||
|
2over nth-check-eof {
|
||||||
|
{ [ 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 )
|
||||||
|
[ drop [ slice-til-whitespace drop ] dip span-slices make-tag-literal ] ! (foo)
|
||||||
|
} cond
|
||||||
|
] ;
|
||||||
|
|
||||||
|
: read-bracket ( n string slice -- n' string slice' ) CHAR: [ read-matched ;
|
||||||
|
: read-brace ( n string slice -- n' string slice' ) CHAR: { read-matched ;
|
||||||
|
: read-paren ( n string slice -- n' string slice' ) CHAR: ( read-matched ;
|
||||||
|
|
||||||
|
: read-backtick ( n string opening -- n' string obj )
|
||||||
|
[
|
||||||
|
slice-til-whitespace drop
|
||||||
|
dup
|
||||||
|
] dip 1 cut-slice* backtick-literal make-delimited-literal ;
|
||||||
|
|
||||||
|
: read-string-payload ( n string -- n' string )
|
||||||
|
over [
|
||||||
|
{ CHAR: \ CHAR: " } slice-til-separator-inclusive {
|
||||||
|
{ f [ drop ] }
|
||||||
|
{ CHAR: " [ drop ] }
|
||||||
|
{ CHAR: \ [ drop next-char-from drop read-string-payload ] }
|
||||||
|
} case
|
||||||
|
] [
|
||||||
|
string-expected-got-eof
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
:: read-string ( n string tag -- n' string seq )
|
||||||
|
n string read-string-payload drop :> n'
|
||||||
|
n' string
|
||||||
|
n' [ n string string-expected-got-eof ] unless
|
||||||
|
n n' 1 - string <slice>
|
||||||
|
n' 1 - n' string <slice>
|
||||||
|
tag 1 cut-slice* dquote-literal make-matched-literal ;
|
||||||
|
|
||||||
|
: take-comment ( n string slice -- n' string comment )
|
||||||
|
2over ?nth CHAR: [ = [
|
||||||
|
[ 1 + ] 2dip 2over ?nth read-double-matched-bracket
|
||||||
|
] [
|
||||||
|
[ slice-til-eol drop dup ] dip 1 cut-slice* line-comment-literal make-delimited-literal
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: read-til-semicolon ( n string slice -- n' string semi )
|
||||||
|
dup '[ but-last ";" append ";" 2array lex-until ] dip
|
||||||
|
1 cut-slice* uppercase-colon-literal make-matched-literal ;
|
||||||
|
|
||||||
|
: read-word-or-til-semicolon ( n string slice -- n' string obj )
|
||||||
|
2over next-char-from* "\s\r\n" member? [
|
||||||
|
read-til-semicolon
|
||||||
|
] [
|
||||||
|
merge-slice-til-whitespace make-tag-literal
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: read-lowercase-colon ( n string slice -- n' string lowercase-colon )
|
||||||
|
[ lex-factor dup ] dip 1 cut-slice*
|
||||||
|
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 ;
|
||||||
|
: read-colon ( n string slice -- n' string colon )
|
||||||
|
dup length 1 = [
|
||||||
|
dup prev-char-from-slice { CHAR: \s CHAR: \r CHAR: \n f } member? [
|
||||||
|
dup next-char-from-slice { CHAR: \s CHAR: \r CHAR: \n f } member? [
|
||||||
|
read-til-semicolon
|
||||||
|
] [
|
||||||
|
merge-slice-til-whitespace make-tag-literal
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
read-lowercase-colon
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
{
|
||||||
|
{ [ dup strict-upper? ] [ read-til-semicolon ] }
|
||||||
|
[ read-lowercase-colon ]
|
||||||
|
} cond
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! Words like append! and suffix! are allowed for now.
|
||||||
|
: read-exclamation ( n string slice -- n' string obj )
|
||||||
|
dup { [ "!" sequence= ] [ "#!" sequence= ] } 1||
|
||||||
|
[ take-comment ] [ merge-slice-til-whitespace make-tag-literal ] if ;
|
||||||
|
|
||||||
|
ERROR: backslash-expects-whitespace slice ;
|
||||||
|
: read-backslash ( n string slice -- n' string obj )
|
||||||
|
2over peek-from blank? [
|
||||||
|
! \ foo, M\ foo
|
||||||
|
[ skip-blank-from slice-til-whitespace drop dup ] dip 1 cut-slice* backslash-literal make-delimited-literal
|
||||||
|
] [
|
||||||
|
! M\N
|
||||||
|
merge-slice-til-whitespace make-tag-literal
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! If the slice is 0 width, we stopped on whitespace.
|
||||||
|
! Advance the index and read again!
|
||||||
|
: read-token-or-whitespace ( n string slice -- n' string slice )
|
||||||
|
dup length 0 =
|
||||||
|
[ drop [ 1 + ] dip lex-factor ]
|
||||||
|
[ make-tag-literal ] if ;
|
||||||
|
|
||||||
|
ERROR: mismatched-terminator n string slice ;
|
||||||
|
: read-terminator ( n string slice -- n' string slice )
|
||||||
|
terminator-literal make-tag-class-literal ;
|
||||||
|
|
||||||
|
: ?blank? ( ch/f -- blank/f )
|
||||||
|
{ [ blank? ] [ f = ] } 1|| ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
! work on underlying, index is on the @
|
||||||
|
! @foo
|
||||||
|
: left-decorator? ( obj -- ? )
|
||||||
|
{
|
||||||
|
[ char-before-slice ?blank? ]
|
||||||
|
[ next-char-from-slice ?blank? not ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
! foo@
|
||||||
|
: right-decorator? ( slice -- ? )
|
||||||
|
{
|
||||||
|
[ prev-char-from-slice-end ?blank? not ]
|
||||||
|
[ next-char-from-slice ?blank? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: read-decorator ( n string slice -- n' string obj )
|
||||||
|
{
|
||||||
|
{ [ dup left-decorator? ] [ t make-decorator-sentinel ] }
|
||||||
|
{ [ dup right-decorator? ] [
|
||||||
|
dup length 1 > [
|
||||||
|
[ -1 + ] 2dip
|
||||||
|
-1 modify-to make-tag-literal
|
||||||
|
] [
|
||||||
|
f make-decorator-sentinel
|
||||||
|
] if ] }
|
||||||
|
[ make-tag-literal ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
SYMBOL: lexing-delimiters
|
||||||
|
|
||||||
|
: add-lexing-delimiter ( rule -- )
|
||||||
|
[ ] [ delimiter>> ] bi lexing-delimiters get set-once-at ;
|
||||||
|
|
||||||
|
<<
|
||||||
|
: lexer-rules>hashtable ( seq -- obj )
|
||||||
|
H{ } clone lexing-delimiters [
|
||||||
|
[ add-lexing-delimiter ] each
|
||||||
|
lexing-delimiters get
|
||||||
|
] with-variable ;
|
||||||
|
|
||||||
|
: lexer-rules>delimiters ( seq -- string )
|
||||||
|
[ delimiter>> ] "" map-as ;
|
||||||
|
|
||||||
|
: lexer-rules>assoc ( seq -- seq' )
|
||||||
|
[ [ delimiter>> ] [ generator>> 1quotation ] bi ] { } map>assoc ;
|
||||||
|
>>
|
||||||
|
|
||||||
|
MACRO: rules>call-lexer ( seq -- quot: ( n/f string -- n'/f string literal ) )
|
||||||
|
[ lexer-rules>delimiters ]
|
||||||
|
[
|
||||||
|
lexer-rules>assoc
|
||||||
|
{ f [ f like dup [ make-tag-literal ] when ] } suffix
|
||||||
|
] bi
|
||||||
|
'[ _ slice-til-either _ case ] ;
|
||||||
|
|
||||||
|
CONSTANT: factor-lexing-rules {
|
||||||
|
T{ line-comment-lexer { generator read-exclamation } { delimiter CHAR: ! } }
|
||||||
|
T{ backtick-lexer { generator read-backtick } { delimiter CHAR: ` } }
|
||||||
|
T{ backslash-lexer { generator read-backslash } { delimiter CHAR: \ } }
|
||||||
|
T{ dquote-lexer { generator read-string } { delimiter CHAR: " } { escape CHAR: \ } }
|
||||||
|
T{ decorator-lexer { generator read-decorator } { delimiter CHAR: @ } }
|
||||||
|
|
||||||
|
T{ colon-lexer { generator read-colon } { delimiter CHAR: : } }
|
||||||
|
T{ matched-lexer { generator read-bracket } { delimiter CHAR: [ } }
|
||||||
|
T{ matched-lexer { generator read-brace } { delimiter CHAR: { } }
|
||||||
|
T{ matched-lexer { generator read-paren } { delimiter CHAR: ( } }
|
||||||
|
|
||||||
|
T{ terminator-lexer { generator read-terminator } { delimiter CHAR: ; } }
|
||||||
|
T{ terminator-lexer { generator read-terminator } { delimiter CHAR: ] } }
|
||||||
|
T{ terminator-lexer { generator read-terminator } { delimiter CHAR: } } }
|
||||||
|
T{ terminator-lexer { generator read-terminator } { delimiter CHAR: ) } }
|
||||||
|
|
||||||
|
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter CHAR: \s } }
|
||||||
|
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter CHAR: \r } }
|
||||||
|
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter CHAR: \n } }
|
||||||
|
}
|
||||||
|
|
||||||
|
: lex-factor ( n/f string -- n'/f string literal )
|
||||||
|
factor-lexing-rules rules>call-lexer ;
|
||||||
|
|
||||||
|
: string>literals ( string -- sequence )
|
||||||
|
[ 0 ] dip [ lex-factor ] loop>array 2nip postprocess-lexed ;
|
||||||
|
|
||||||
|
: vocab>literals ( vocab -- sequence )
|
||||||
|
".private" ?tail drop
|
||||||
|
modern-source-path utf8 file-contents string>literals ;
|
||||||
|
|
||||||
|
: path>literals ( path -- sequence )
|
||||||
|
utf8 file-contents string>literals ;
|
||||||
|
|
||||||
|
: lex-core ( -- assoc )
|
||||||
|
core-bootstrap-vocabs [ [ vocab>literals ] [ nip ] recover ] map-zip ;
|
||||||
|
|
||||||
|
: filter-lex-errors ( assoc -- assoc' )
|
||||||
|
[ nip array? not ] assoc-filter ;
|
||||||
|
|
||||||
|
|
||||||
|
/*
|
||||||
|
! What a lexer body looks like, produced by make-lexer
|
||||||
|
: lex ( n/f string -- n'/f string literal )
|
||||||
|
"!`\\\"[{(\s\r\n" slice-til-either {
|
||||||
|
{ CHAR: ! [ read-exclamation ] }
|
||||||
|
{ CHAR: ` [ read-backtick ] }
|
||||||
|
{ CHAR: \ [ read-backslash ] }
|
||||||
|
{ CHAR: " [ read-string ] }
|
||||||
|
{ CHAR: [ [ read-bracket ] }
|
||||||
|
{ CHAR: { [ read-brace ] }
|
||||||
|
{ CHAR: ( [ read-paren ] }
|
||||||
|
{ CHAR: \s [ read-token-or-whitespace ] }
|
||||||
|
{ CHAR: \r [ read-token-or-whitespace ] }
|
||||||
|
{ CHAR: \n [ read-token-or-whitespace ] }
|
||||||
|
{ f [ f like dup [ make-tag-literal ] when ] }
|
||||||
|
} case ; inline
|
||||||
|
*/
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,56 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators.short-circuit kernel modern
|
||||||
|
modern.out sequences tools.test multiline ;
|
||||||
|
IN: modern.out.tests
|
||||||
|
|
||||||
|
: rewrite-same-string ( string -- ? )
|
||||||
|
[ [ ] rewrite-string ] keep sequence= ;
|
||||||
|
|
||||||
|
: rename-backtick-delimiter ( string -- string' )
|
||||||
|
[
|
||||||
|
dup backtick-literal? [ [ drop "^" ] change-delimiter ] when
|
||||||
|
] rewrite-string ;
|
||||||
|
|
||||||
|
: rename-backslash-delimiter ( string -- string' )
|
||||||
|
[
|
||||||
|
dup backslash-literal? [ [ drop "^" ] change-delimiter ] when
|
||||||
|
] rewrite-string ;
|
||||||
|
|
||||||
|
{ t } [ "fixnum`33 ch`@" rewrite-same-string ] unit-test
|
||||||
|
{ t } [ "! omg" rewrite-same-string ] unit-test
|
||||||
|
{ t } [ "todo! omg" rewrite-same-string ] unit-test
|
||||||
|
{ t } [ "foo[ bar{ baz( ) } ]" rewrite-same-string ] unit-test
|
||||||
|
|
||||||
|
{ t } [ " ARRAY: ;" rewrite-same-string ] unit-test
|
||||||
|
{ t } [ " ARRAY: 1 ;{ inline }" rewrite-same-string ] unit-test
|
||||||
|
{ t } [ " ARRAY: 1 ;[ 0 ]" rewrite-same-string ] unit-test
|
||||||
|
|
||||||
|
{ t } [ " abc{ 1 2 3 abc}" rewrite-same-string ] unit-test
|
||||||
|
{ t } [ " ABC: abc{ 1 2 3 abc} ABC;" rewrite-same-string ] unit-test
|
||||||
|
{ t } [ " a{ a{ a{ a} } a}" rewrite-same-string ] unit-test
|
||||||
|
|
||||||
|
! Funky spaced decorator test
|
||||||
|
{ t } [
|
||||||
|
" lol@ { 1 }@ { 2 }@ hi @{ 3 } @{ 4 } @inline" rewrite-same-string
|
||||||
|
] unit-test
|
||||||
|
! Disable these for now.
|
||||||
|
! { t } [ " array: 1" rewrite-same-string ] unit-test
|
||||||
|
! { t } [ " { array: 1 array: 2 }" rewrite-same-string ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
{ "fixnum^33 ch^@" } [ "fixnum`33 ch`@" rename-backtick-delimiter ] unit-test
|
||||||
|
|
||||||
|
{ "^ foo ^ bar" } [ "\\ foo \\ bar" rename-backslash-delimiter ] unit-test
|
||||||
|
|
||||||
|
/*
|
||||||
|
{ ": asdf < '< > > ;" } [
|
||||||
|
": asdf [ '[ ] ] ;" [
|
||||||
|
dup { [ single-matched-literal? ] [ delimiter>> "[" = ] } 1&&
|
||||||
|
[ [ drop "<" ] change-delimiter ] when
|
||||||
|
] rewrite-string
|
||||||
|
] unit-test
|
||||||
|
*/
|
||||||
|
|
||||||
|
! lexable-paths [ transform-single-line-comment>hash-comment ] rewrite-paths
|
||||||
|
|
@ -0,0 +1,311 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators combinators.short-circuit
|
||||||
|
combinators.smart continuations fry io io.encodings.utf8
|
||||||
|
io.files io.streams.string kernel modern modern.paths
|
||||||
|
modern.slices multiline namespaces prettyprint sequences sets
|
||||||
|
splitting strings arrays ;
|
||||||
|
IN: modern.out
|
||||||
|
|
||||||
|
SYMBOL: last-slice
|
||||||
|
|
||||||
|
: write-whitespace ( obj -- )
|
||||||
|
[ last-slice get [ swap slice-between ] [ slice-before ] if* io:write ]
|
||||||
|
[ last-slice namespaces:set ] bi ;
|
||||||
|
|
||||||
|
DEFER: write-literal
|
||||||
|
GENERIC: write-literal ( obj -- )
|
||||||
|
! M: object write-literal lexed-underlying write ;
|
||||||
|
M: string write-literal write ;
|
||||||
|
M: slice write-literal [ write-whitespace ] [ write ] bi ;
|
||||||
|
|
||||||
|
M: array write-literal [ write-literal ] each ;
|
||||||
|
|
||||||
|
M: tag-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: single-matched-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> write ]
|
||||||
|
[ payload>> [ write-literal ] each ] ! don't need write-whitespace here, the recursion does it
|
||||||
|
[ seq>> 3 swap nth lexed-underlying write-whitespace ]
|
||||||
|
[ closing-tag>> write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: double-matched-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> io:write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
[ seq>> 2 swap nth write-whitespace ]
|
||||||
|
[ payload>> io:write ]
|
||||||
|
[ seq>> 3 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> matching-delimiter-string io:write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: dquote-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> io:write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
[ seq>> 2 swap nth write-whitespace ]
|
||||||
|
[ payload>> io:write ]
|
||||||
|
[ seq>> 3 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> matching-delimiter-string io:write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: backtick-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> io:write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
[ seq>> 2 swap nth write-whitespace ]
|
||||||
|
[ payload>> io:write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: backslash-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> io:write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
[ seq>> 2 swap nth write-whitespace ]
|
||||||
|
[ payload>> io:write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: line-comment-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> io:write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
[ seq>> 2 swap nth write-whitespace ]
|
||||||
|
[ payload>> io:write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: uppercase-colon-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> write ]
|
||||||
|
[ payload>> [ write-literal ] each ] ! don't need write-whitespace here, the recursion does it
|
||||||
|
[ seq>> 3 swap nth lexed-underlying write-whitespace ]
|
||||||
|
[ closing-tag>> write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: lowercase-colon-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ tag>> io:write ]
|
||||||
|
[ seq>> 1 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
[ payload>> write-literal ] ! don't need write-whitespace here, the recursion does it
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: left-decorator-literal write-literal
|
||||||
|
{
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
[ payload>> write-literal ] ! don't need write-whitespace here, the recursion does it
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: right-decorator-literal write-literal
|
||||||
|
{
|
||||||
|
[ payload>> write-literal ] ! don't need write-whitespace here, the recursion does it
|
||||||
|
[ seq>> 0 swap nth write-whitespace ]
|
||||||
|
[ delimiter>> io:write ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: compound-literal write-literal
|
||||||
|
sequence>> [ write-literal ] each ;
|
||||||
|
|
||||||
|
M: compound-sequence-literal write-literal
|
||||||
|
sequence>> [ write-literal ] each ;
|
||||||
|
|
||||||
|
! Swap in write-literal for renaming
|
||||||
|
|
||||||
|
: write-modern-loop ( quot -- )
|
||||||
|
[ write-literal ] each ; inline
|
||||||
|
|
||||||
|
: write-modern-string ( seq -- string )
|
||||||
|
[ write-modern-loop ] with-string-writer ; inline
|
||||||
|
|
||||||
|
: write-modern-path ( seq path -- )
|
||||||
|
utf8 [ write-modern-loop nl ] with-file-writer ; inline
|
||||||
|
|
||||||
|
: map-literals ( obj quot: ( obj -- obj' ) -- seq )
|
||||||
|
over single-matched-literal? [
|
||||||
|
[ call drop ] [
|
||||||
|
'[
|
||||||
|
dup compound-sequence-literal? [ sequence>> ] when
|
||||||
|
[ _ map-literals ] map
|
||||||
|
] change-payload
|
||||||
|
] 2bi
|
||||||
|
] [
|
||||||
|
call
|
||||||
|
] if ; inline recursive
|
||||||
|
|
||||||
|
: rewrite-path ( path quot -- )
|
||||||
|
! dup print
|
||||||
|
'[ [ path>literals [ _ map-literals ] map ] [ ] bi write-modern-path ]
|
||||||
|
[ drop . ] recover ; inline
|
||||||
|
|
||||||
|
: rewrite-string ( string quot -- )
|
||||||
|
! dup print
|
||||||
|
[ string>literals ] dip '[ _ map-literals ] map write-modern-string ; inline
|
||||||
|
|
||||||
|
: rewrite-paths ( seq quot -- ) '[ _ rewrite-path ] each ; inline
|
||||||
|
: lexable-core-paths ( -- seq ) core-source-paths ;
|
||||||
|
: lexable-basis-paths ( -- seq )
|
||||||
|
basis-source-paths {
|
||||||
|
"resource:basis/bit-arrays/bit-arrays.factor"
|
||||||
|
"resource:basis/bit-vectors/bit-vectors.factor"
|
||||||
|
"resource:basis/csv/csv.factor"
|
||||||
|
"resource:basis/dlists/dlists.factor"
|
||||||
|
"resource:basis/eval/eval.factor"
|
||||||
|
"resource:basis/farkup/farkup.factor"
|
||||||
|
"resource:basis/fry/fry.factor"
|
||||||
|
"resource:basis/linked-assocs/linked-assocs.factor"
|
||||||
|
"resource:basis/literals/literals.factor"
|
||||||
|
"resource:basis/nibble-arrays/nibble-arrays.factor"
|
||||||
|
"resource:basis/shuffle/shuffle.factor"
|
||||||
|
"resource:basis/simple-tokenizer/simple-tokenizer.factor"
|
||||||
|
"resource:basis/specialized-arrays/specialized-arrays.factor"
|
||||||
|
"resource:basis/specialized-vectors/specialized-vectors.factor"
|
||||||
|
"resource:basis/suffix-arrays/suffix-arrays.factor"
|
||||||
|
"resource:basis/urls/urls.factor"
|
||||||
|
"resource:basis/vlists/vlists.factor"
|
||||||
|
"resource:basis/alien/data/data.factor"
|
||||||
|
"resource:basis/alien/syntax/syntax.factor"
|
||||||
|
"resource:basis/byte-arrays/hex/hex.factor"
|
||||||
|
"resource:basis/classes/struct/struct.factor"
|
||||||
|
"resource:basis/cocoa/messages/messages.factor"
|
||||||
|
"resource:basis/db/postgresql/errors/errors.factor"
|
||||||
|
"resource:basis/hash-sets/identity/identity.factor"
|
||||||
|
"resource:basis/hash-sets/sequences/sequences.factor"
|
||||||
|
"resource:basis/hashtables/identity/identity.factor"
|
||||||
|
"resource:basis/hashtables/sequences/sequences.factor"
|
||||||
|
"resource:basis/help/handbook/handbook.factor"
|
||||||
|
"resource:basis/help/html/html.factor"
|
||||||
|
"resource:basis/html/templates/fhtml/fhtml.factor"
|
||||||
|
"resource:basis/http/parsers/parsers.factor"
|
||||||
|
"resource:basis/io/encodings/iso2022/iso2022.factor"
|
||||||
|
"resource:basis/json/reader/reader.factor"
|
||||||
|
"resource:basis/json/writer/writer.factor"
|
||||||
|
"resource:basis/math/complex/complex.factor"
|
||||||
|
"resource:basis/math/vectors/simd/simd.factor"
|
||||||
|
"resource:basis/math/vectors/simd/cords/cords.factor"
|
||||||
|
"resource:basis/memoize/syntax/syntax.factor"
|
||||||
|
"resource:basis/peg/ebnf/ebnf.factor"
|
||||||
|
"resource:basis/peg/parsers/parsers.factor"
|
||||||
|
"resource:basis/persistent/hashtables/hashtables.factor"
|
||||||
|
"resource:basis/persistent/vectors/vectors.factor"
|
||||||
|
"resource:basis/regexp/parser/parser.factor"
|
||||||
|
"resource:basis/xml/autoencoding/autoencoding.factor"
|
||||||
|
"resource:basis/xml/dtd/dtd.factor"
|
||||||
|
"resource:basis/xml/elements/elements.factor"
|
||||||
|
"resource:basis/xml/entities/entities.factor"
|
||||||
|
} diff ;
|
||||||
|
|
||||||
|
: lexable-extra-paths ( -- seq )
|
||||||
|
extra-source-paths {
|
||||||
|
"resource:extra/brainfuck/brainfuck.factor" ! EBNF: [[ ]] ;
|
||||||
|
"resource:extra/cuesheet/cuesheet.factor" ! CHAR: "
|
||||||
|
"resource:extra/fjsc/fjsc.factor" ! EBNF:
|
||||||
|
"resource:extra/emojify/emojify.factor" ! R/
|
||||||
|
"resource:extra/gml/gml.factor"
|
||||||
|
"resource:extra/metar/metar.factor" ! R/
|
||||||
|
"resource:extra/morse/morse.factor"
|
||||||
|
"resource:extra/rosetta-code/balanced-brackets/balanced-brackets.factor"
|
||||||
|
"resource:extra/flip-text/flip-text.factor"
|
||||||
|
"resource:extra/ini-file/ini-file.factor"
|
||||||
|
"resource:extra/poker/poker.factor"
|
||||||
|
"resource:extra/qw/qw.factor"
|
||||||
|
"resource:extra/svg/svg.factor"
|
||||||
|
"resource:extra/text-to-pdf/text-to-pdf.factor"
|
||||||
|
"resource:extra/tnetstrings/tnetstrings.factor"
|
||||||
|
"resource:extra/trees/trees.factor"
|
||||||
|
"resource:extra/alien/data/map/map.factor"
|
||||||
|
"resource:extra/arrays/shaped/shaped.factor"
|
||||||
|
"resource:extra/bunny/outlined/outlined.factor"
|
||||||
|
"resource:extra/c/lexer/lexer.factor"
|
||||||
|
"resource:extra/c/preprocessor/preprocessor.factor"
|
||||||
|
"resource:extra/gml/parser/parser.factor"
|
||||||
|
"resource:extra/gml/runtime/runtime.factor"
|
||||||
|
"resource:extra/gpu/effects/blur/blur.factor"
|
||||||
|
"resource:extra/hash-sets/numbers/numbers.factor"
|
||||||
|
"resource:extra/hashtables/numbers/numbers.factor"
|
||||||
|
"resource:extra/html/parser/parser.factor"
|
||||||
|
"resource:extra/infix/parser/parser.factor"
|
||||||
|
"resource:extra/infix/tokenizer/tokenizer.factor"
|
||||||
|
"resource:extra/parser-combinators/simple/simple.factor"
|
||||||
|
"resource:extra/pdf/values/values.factor"
|
||||||
|
"resource:extra/peg/pl0/pl0.factor"
|
||||||
|
"resource:extra/peg/javascript/parser/parser.factor"
|
||||||
|
"resource:extra/peg/javascript/tokenizer/tokenizer.factor"
|
||||||
|
"resource:extra/project-euler/011/011.factor"
|
||||||
|
"resource:extra/rosetta-code/balanced-brackets/balanced-bracke..."
|
||||||
|
"resource:extra/slots/syntax/syntax.factor"
|
||||||
|
"resource:extra/smalltalk/parser/parser.factor"
|
||||||
|
"resource:extra/talks/galois-talk/galois-talk.factor"
|
||||||
|
"resource:extra/talks/google-tech-talk/google-tech-talk.factor"
|
||||||
|
"resource:extra/talks/otug-talk/otug-talk.factor"
|
||||||
|
"resource:extra/talks/vpri-talk/vpri-talk.factor"
|
||||||
|
"resource:extra/trees/avl/avl.factor"
|
||||||
|
"resource:extra/trees/splay/splay.factor"
|
||||||
|
"resource:extra/yaml/conversion/conversion.factor"
|
||||||
|
} diff ;
|
||||||
|
|
||||||
|
/*
|
||||||
|
! These work except they use pegs/ebnf, grep for [[ ]]
|
||||||
|
modified: basis/db/sqlite/errors/errors.factor
|
||||||
|
modified: basis/formatting/formatting.factor
|
||||||
|
modified: basis/globs/globs.factor
|
||||||
|
modified: extra/alien/fortran/fortran.factor
|
||||||
|
modified: extra/cpu/8080/emulator/emulator.factor
|
||||||
|
modified: extra/peg/expr/expr.factor
|
||||||
|
modified: extra/rosetta-code/arithmetic-evaluation/arithmetic-evaluation.factor
|
||||||
|
modified: extra/shell/parser/parser.factor
|
||||||
|
*/
|
||||||
|
|
||||||
|
: lexable-paths ( -- seq )
|
||||||
|
[
|
||||||
|
lexable-core-paths
|
||||||
|
lexable-basis-paths
|
||||||
|
lexable-extra-paths
|
||||||
|
] append-outputs ;
|
||||||
|
|
||||||
|
: paren-word>tick-word ( string -- string' )
|
||||||
|
dup [ "(" ?head drop ")" ?tail drop "'" append ] [ ] if ;
|
||||||
|
|
||||||
|
: paren-word-name? ( string -- ? )
|
||||||
|
{ [ "(" head? ] [ ")" tail? ] } 1&& ;
|
||||||
|
|
||||||
|
: transform-paren-word>tick-word ( token -- token' )
|
||||||
|
dup { [ tag-literal? ] [ tag>> paren-word-name? ] } 1&& [
|
||||||
|
[ paren-word>tick-word ] change-tag
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: single-line-comment? ( token -- ? )
|
||||||
|
{ [ line-comment-literal? ] [ delimiter>> "!" sequence= ] } 1&& ;
|
||||||
|
|
||||||
|
: transform-single-line-comment>hash-comment ( token -- token' )
|
||||||
|
dup single-line-comment? [
|
||||||
|
[ drop "#" ] change-delimiter
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: transform-source ( quot -- )
|
||||||
|
lexable-paths swap rewrite-paths ; inline
|
||||||
|
|
||||||
|
: transform-core ( quot -- )
|
||||||
|
lexable-core-paths swap rewrite-paths ; inline
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,134 @@
|
||||||
|
! Copyright (C) 2015 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors combinators.smart io.files kernel sequences
|
||||||
|
splitting vocabs.files vocabs.hierarchy vocabs.loader
|
||||||
|
vocabs.metadata sets ;
|
||||||
|
IN: modern.paths
|
||||||
|
|
||||||
|
: modern-if-available ( path -- path' )
|
||||||
|
dup ".factor" ?tail [
|
||||||
|
".modern" append
|
||||||
|
dup exists? [ nip ] [ drop ] if
|
||||||
|
] [
|
||||||
|
drop
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
ERROR: not-a-source-path path ;
|
||||||
|
: force-modern-path ( path -- path' )
|
||||||
|
".factor" ?tail [ ".modern" append ] [ not-a-source-path ] if ;
|
||||||
|
: modern-docs-path ( path -- path' )
|
||||||
|
vocab-docs-path modern-if-available ;
|
||||||
|
: modern-tests-path ( path -- path' )
|
||||||
|
vocab-tests-path modern-if-available ;
|
||||||
|
: modern-source-path ( path -- path' )
|
||||||
|
vocab-source-path modern-if-available ;
|
||||||
|
: modern-syntax-path ( path -- path' )
|
||||||
|
vocab-source-path ".factor" ?tail drop "-syntax.modern" append ;
|
||||||
|
|
||||||
|
: force-modern-docs-path ( path -- path' )
|
||||||
|
vocab-docs-path force-modern-path ;
|
||||||
|
: force-modern-tests-path ( path -- path' )
|
||||||
|
vocab-tests-path force-modern-path ;
|
||||||
|
: force-modern-source-path ( path -- path' )
|
||||||
|
vocab-source-path force-modern-path ;
|
||||||
|
|
||||||
|
: vocabs-from ( root -- vocabs )
|
||||||
|
"" disk-vocabs-in-root/prefix
|
||||||
|
no-prefixes [ name>> ] map ;
|
||||||
|
|
||||||
|
: core-vocabs ( -- seq ) "resource:core" vocabs-from ;
|
||||||
|
: less-core-test-vocabs ( seq -- seq' )
|
||||||
|
{
|
||||||
|
"vocabs.loader.test.a"
|
||||||
|
"vocabs.loader.test.b"
|
||||||
|
"vocabs.loader.test.c"
|
||||||
|
"vocabs.loader.test.d"
|
||||||
|
"vocabs.loader.test.e"
|
||||||
|
"vocabs.loader.test.f"
|
||||||
|
"vocabs.loader.test.g"
|
||||||
|
"vocabs.loader.test.h"
|
||||||
|
"vocabs.loader.test.i"
|
||||||
|
"vocabs.loader.test.j"
|
||||||
|
"vocabs.loader.test.k"
|
||||||
|
"vocabs.loader.test.l"
|
||||||
|
"vocabs.loader.test.m"
|
||||||
|
"vocabs.loader.test.n"
|
||||||
|
"vocabs.loader.test.o"
|
||||||
|
"vocabs.loader.test.p"
|
||||||
|
} diff ;
|
||||||
|
|
||||||
|
: core-bootstrap-vocabs ( -- seq )
|
||||||
|
core-vocabs less-core-test-vocabs ;
|
||||||
|
|
||||||
|
: basis-vocabs ( -- seq ) "resource:basis" vocabs-from ;
|
||||||
|
: extra-vocabs ( -- seq ) "resource:extra" vocabs-from ;
|
||||||
|
: all-vocabs ( -- seq )
|
||||||
|
[
|
||||||
|
core-vocabs
|
||||||
|
basis-vocabs
|
||||||
|
extra-vocabs
|
||||||
|
] { } append-outputs-as ;
|
||||||
|
|
||||||
|
: filter-exists ( seq -- seq' ) [ exists? ] filter ;
|
||||||
|
|
||||||
|
! These paths have syntax errors on purpose...
|
||||||
|
: reject-some-paths ( seq -- seq' )
|
||||||
|
{
|
||||||
|
"resource:core/vocabs/loader/test/a/a.factor"
|
||||||
|
"resource:core/vocabs/loader/test/b/b.factor"
|
||||||
|
"resource:core/vocabs/loader/test/c/c.factor"
|
||||||
|
! Here down have parse errors
|
||||||
|
"resource:core/vocabs/loader/test/d/d.factor"
|
||||||
|
"resource:core/vocabs/loader/test/e/e.factor"
|
||||||
|
"resource:core/vocabs/loader/test/f/f.factor"
|
||||||
|
"resource:core/vocabs/loader/test/g/g.factor"
|
||||||
|
"resource:core/vocabs/loader/test/h/h.factor"
|
||||||
|
"resource:core/vocabs/loader/test/i/i.factor"
|
||||||
|
"resource:core/vocabs/loader/test/j/j.factor"
|
||||||
|
"resource:core/vocabs/loader/test/k/k.factor"
|
||||||
|
"resource:core/vocabs/loader/test/l/l.factor"
|
||||||
|
"resource:core/vocabs/loader/test/m/m.factor"
|
||||||
|
"resource:core/vocabs/loader/test/n/n.factor"
|
||||||
|
"resource:core/vocabs/loader/test/o/o.factor"
|
||||||
|
"resource:core/vocabs/loader/test/p/p.factor"
|
||||||
|
"resource:extra/math/blas/vectors/vectors.factor" ! need .modern file
|
||||||
|
"resource:extra/math/blas/matrices/matrices.factor" ! need .modern file
|
||||||
|
} diff
|
||||||
|
! Don't parse .modern files yet
|
||||||
|
[ ".modern" tail? ] reject ;
|
||||||
|
|
||||||
|
: modern-source-paths ( names -- paths )
|
||||||
|
[ modern-source-path ] map filter-exists reject-some-paths ;
|
||||||
|
: modern-docs-paths ( names -- paths )
|
||||||
|
[ modern-docs-path ] map filter-exists reject-some-paths ;
|
||||||
|
: modern-tests-paths ( names -- paths )
|
||||||
|
[ vocab-tests ] map concat
|
||||||
|
[ modern-if-available ] map filter-exists reject-some-paths ;
|
||||||
|
|
||||||
|
: all-source-paths ( -- seq )
|
||||||
|
all-vocabs modern-source-paths ;
|
||||||
|
|
||||||
|
: all-docs-paths ( -- seq )
|
||||||
|
all-vocabs modern-docs-paths ;
|
||||||
|
|
||||||
|
: all-tests-paths ( -- seq )
|
||||||
|
all-vocabs modern-tests-paths ;
|
||||||
|
|
||||||
|
: all-syntax-paths ( -- seq )
|
||||||
|
all-vocabs [ modern-syntax-path ] map filter-exists reject-some-paths ;
|
||||||
|
|
||||||
|
: all-factor-paths ( -- seq )
|
||||||
|
[
|
||||||
|
all-syntax-paths all-source-paths all-docs-paths all-tests-paths
|
||||||
|
] { } append-outputs-as ;
|
||||||
|
|
||||||
|
: vocab-names>syntax ( strings -- seq )
|
||||||
|
[ modern-syntax-path ] map [ exists? ] filter ;
|
||||||
|
|
||||||
|
: core-syntax-paths ( -- seq ) core-vocabs vocab-names>syntax reject-some-paths ;
|
||||||
|
: basis-syntax-paths ( -- seq ) basis-vocabs vocab-names>syntax reject-some-paths ;
|
||||||
|
: extra-syntax-paths ( -- seq ) extra-vocabs vocab-names>syntax reject-some-paths ;
|
||||||
|
|
||||||
|
: core-source-paths ( -- seq ) core-vocabs modern-source-paths reject-some-paths ;
|
||||||
|
: basis-source-paths ( -- seq ) basis-vocabs modern-source-paths reject-some-paths ;
|
||||||
|
: extra-source-paths ( -- seq ) extra-vocabs modern-source-paths reject-some-paths ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,199 @@
|
||||||
|
! Copyright (C) 2016 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors assocs fry kernel locals math math.private
|
||||||
|
sequences sequences.extras sequences.private unicode ;
|
||||||
|
IN: modern.slices
|
||||||
|
|
||||||
|
: matching-delimiter ( ch -- ch' )
|
||||||
|
H{
|
||||||
|
{ CHAR: ( CHAR: ) }
|
||||||
|
{ CHAR: [ CHAR: ] }
|
||||||
|
{ CHAR: { CHAR: } }
|
||||||
|
{ CHAR: < CHAR: > }
|
||||||
|
{ CHAR: : CHAR: ; }
|
||||||
|
} ?at drop ;
|
||||||
|
|
||||||
|
: matching-delimiter-string ( string -- string' )
|
||||||
|
[ matching-delimiter ] map ;
|
||||||
|
|
||||||
|
ERROR: unexpected-end n string ;
|
||||||
|
: nth-check-eof ( n string -- nth )
|
||||||
|
2dup ?nth [ 2nip ] [ unexpected-end ] if* ;
|
||||||
|
|
||||||
|
: peek-from ( n/f string -- ch )
|
||||||
|
over [ ?nth ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
! Allow eof
|
||||||
|
: next-char-from ( n/f string -- n'/f string ch/f )
|
||||||
|
over [
|
||||||
|
2dup ?nth [ [ 1 + ] 2dip ] [ f ] if*
|
||||||
|
] [
|
||||||
|
[ 2drop f ] [ nip ] 2bi f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: prev-char-from-slice-end ( slice -- ch/f )
|
||||||
|
[ to>> 2 - ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: prev-char-from-slice ( slice -- ch/f )
|
||||||
|
[ from>> 1 - ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: next-char-from-slice ( slice -- ch/f )
|
||||||
|
[ to>> ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: char-before-slice ( slice -- ch/f )
|
||||||
|
[ from>> 1 - ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: char-after-slice ( slice -- ch/f )
|
||||||
|
[ to>> ] [ seq>> ] bi ?nth ;
|
||||||
|
|
||||||
|
: next-char-from* ( n/f string -- ch/f )
|
||||||
|
next-char-from 2nip ;
|
||||||
|
|
||||||
|
: find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
|
||||||
|
[ find-from ] keep
|
||||||
|
pick [ drop t ] [ length -rot nip f ] if ; inline
|
||||||
|
|
||||||
|
: skip-blank-from ( n string -- n' string )
|
||||||
|
[ [ blank? not ] find-from* 2drop ] keep ; inline
|
||||||
|
|
||||||
|
: skip-til-eol-from ( n string -- n' string )
|
||||||
|
[ [ "\r\n" member? ] find-from* 2drop ] keep ; inline
|
||||||
|
|
||||||
|
! Don't include the whitespace in the slice
|
||||||
|
:: slice-til-whitespace ( n string -- n' string slice/f ch/f )
|
||||||
|
n string [ "\s\r\n" member? ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch ; inline
|
||||||
|
|
||||||
|
:: slice-until' ( n string quot -- n' string slice/f ch/f )
|
||||||
|
n string quot find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch ; inline
|
||||||
|
|
||||||
|
: slice-until ( n string quot -- n' string slice/f )
|
||||||
|
slice-until' drop ; inline
|
||||||
|
|
||||||
|
:: slice-til-not-whitespace ( n string -- n' string slice/f ch/f )
|
||||||
|
n string [ "\s\r\n" member? not ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch ; inline
|
||||||
|
|
||||||
|
: skip-whitespace ( n string -- n' string )
|
||||||
|
slice-til-not-whitespace 2drop ;
|
||||||
|
|
||||||
|
: empty-slice-end ( seq -- slice )
|
||||||
|
[ length dup ] [ ] bi <slice> ; inline
|
||||||
|
|
||||||
|
: empty-slice-from ( n seq -- slice )
|
||||||
|
dupd <slice> ; inline
|
||||||
|
|
||||||
|
:: slice-til-eol ( n string -- n' string slice/f ch/f )
|
||||||
|
n [
|
||||||
|
n string '[ "\r\n" member? ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
n string string empty-slice-end f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
:: merge-slice-til-eol-slash'' ( n string -- n' string slice/f ch/f )
|
||||||
|
n [
|
||||||
|
n string '[ "\r\n\\" member? ] find-from :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
n string string empty-slice-end f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
: merge-slice-til-whitespace ( n string slice -- n' string slice' )
|
||||||
|
[ slice-til-whitespace drop ] dip merge-slices ;
|
||||||
|
|
||||||
|
: merge-slice-til-eol ( n string slice -- n' string slice' )
|
||||||
|
[ slice-til-eol drop ] dip merge-slices ;
|
||||||
|
|
||||||
|
: slice-between ( slice1 slice2 -- slice )
|
||||||
|
! ensure-same-underlying
|
||||||
|
slice-order-by-from
|
||||||
|
[ to>> ]
|
||||||
|
[ [ from>> 2dup < [ swap ] unless ] [ seq>> ] bi ] bi* <slice> ;
|
||||||
|
|
||||||
|
: slice-before ( slice -- slice' )
|
||||||
|
[ drop 0 ] [ from>> ] [ seq>> ] tri <slice> ;
|
||||||
|
|
||||||
|
: ?nth' ( n/f string/f -- obj/f )
|
||||||
|
over [ ?nth ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
:: merge-slice-til-eol-slash' ( n string slice -- n' string slice/f ch/f )
|
||||||
|
n string merge-slice-til-eol-slash'' :> ( n' string' slice' ch' )
|
||||||
|
ch' CHAR: \ = [
|
||||||
|
n' 1 + string' ?nth' "\r\n" member? [
|
||||||
|
n' 2 + string' slice slice' span-slices merge-slice-til-eol-slash'
|
||||||
|
] [
|
||||||
|
"omg" throw
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
n' string' slice slice' span-slices ch'
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! Supports \ at eol (with no space after it)
|
||||||
|
: slice-til-eol-slash ( n string -- n' string slice/f ch/f )
|
||||||
|
2dup empty-slice-from merge-slice-til-eol-slash' ;
|
||||||
|
|
||||||
|
:: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
|
||||||
|
n string '[ tokens member? ] find-from [ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch ; inline
|
||||||
|
|
||||||
|
: slice-til-separator-exclusive ( n string tokens -- n' string slice/f ch/f )
|
||||||
|
slice-til-separator-inclusive dup [
|
||||||
|
[ [ 1 - ] change-to ] dip
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
:: slice-til-either ( n string tokens -- n'/f string slice/f ch )
|
||||||
|
n [
|
||||||
|
n string '[ tokens member? ] find-from
|
||||||
|
dup "\s\r\n" member? [
|
||||||
|
:> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] [
|
||||||
|
[ dup [ 1 + ] when ] dip :> ( n' ch )
|
||||||
|
n' string
|
||||||
|
n n' string ?<slice>
|
||||||
|
ch
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
f string f f
|
||||||
|
] if ; inline
|
||||||
|
|
||||||
|
ERROR: subseq-expected-but-got-eof n string expected ;
|
||||||
|
|
||||||
|
:: slice-til-string ( n string search -- n' string payload end-string )
|
||||||
|
search string n start* :> n'
|
||||||
|
n' [ n string search subseq-expected-but-got-eof ] unless
|
||||||
|
n' search length + string
|
||||||
|
n n' string ?<slice>
|
||||||
|
n' dup search length + string ?<slice> ;
|
||||||
|
|
||||||
|
: modify-from ( slice n -- slice' )
|
||||||
|
'[ from>> _ + ] [ to>> ] [ seq>> ] tri <slice> ;
|
||||||
|
|
||||||
|
: modify-to ( slice n -- slice' )
|
||||||
|
[ [ from>> ] [ to>> ] [ seq>> ] tri ] dip
|
||||||
|
swap [ + ] dip <slice> ;
|
||||||
|
|
||||||
|
! { CHAR: ] [ read-closing ] }
|
||||||
|
! { CHAR: } [ read-closing ] }
|
||||||
|
! { CHAR: ) [ read-closing ] }
|
||||||
|
: read-closing ( n string tok -- n string tok )
|
||||||
|
dup length 1 = [
|
||||||
|
-1 modify-to [ 1 - ] 2dip
|
||||||
|
] unless ;
|
||||||
|
|
||||||
Loading…
Reference in New Issue