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

modern: wip

modern-harvey3
Doug Coleman 2019-11-03 15:22:59 -06:00
parent 721ce58b4c
commit e83100b759
3 changed files with 58 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
extra/modern/compiler/compiler.factor
View File

@ -38,17 +38,23 @@ TUPLE: escaped-object < lexed name payload ;
CONSTRUCTOR: <escaped-object> escaped-object ( tokens -- obj ) ;
TUPLE: section < lexed tag payload ;
CONSTRUCTOR: <section> section ( tokens -- obj ) ;
CONSTRUCTOR: <section> section ( tokens -- obj )
dup second >>payload ;
TUPLE: named-section < lexed tag name payload ;
CONSTRUCTOR: <named-section> named-section ( tokens -- obj ) ;
TUPLE: upper-colon < lexed tag payload ;
TUPLE: upper-colon < lexed tag payload decorators ;
CONSTRUCTOR: <upper-colon> upper-colon ( tokens -- obj )
! put this in the fixup-arity/decorators instead
dup tokens>> first but-last-slice >>tag ;
! dup tokens>> [ first but-last-slice >>tag ] [ second >>payload ] bi ;
: add-upper-colon-decorator ( upper-colon obj -- upper-colon )
[ '[ _ suffix ] change-decorators ]
[ '[ _ suffix ] change-tokens ] bi ;
TUPLE: lower-colon < lexed tag payload ;
CONSTRUCTOR: <lower-colon> lower-colon ( tokens -- obj ) ;

27
extra/modern/manifest/manifest.factor
View File

@ -221,16 +221,33 @@ ERROR: key-exists val key assoc existing-value ;
] if ; inline
ERROR: not-a-decorator obj ;
GENERIC#: apply-decorators2 1 ( seq syntax-forms -- seq' )
M: array apply-decorators2
'[ nip dup slice? [ >string _ rdecorators>> at ] [ drop f ] if ] monotonic-split ;
! monotonoic-split doesn't iterate if only one item
over length 1 = [
'[ dup section? [ _ apply-decorators2 ] when ] map
] [
dup '[
nip dup slice? [
>string _ rdecorators>> ?at [ not-a-decorator ] unless
] [
dup section? [
[ _ apply-decorators2 ] change-payload drop f
] [
drop f
] if
] if
] monotonic-split
] if ;
M: section apply-decorators2
'[ _ swap apply-decorators2 ] change-payload ;
'[ _ apply-decorators2 ] change-payload ;
: apply-decorators ( seq syntax-forms -- seq' )
'[ [ nip dup slice? [ >string _ rdecorators>> at ] [ drop f ] if ] monotonic-split ] map-literals ;
! : apply-decorators ( seq syntax-forms -- seq' )
! '[ [ nip dup slice? [ >string _ rdecorators>> at ] [ drop f ] if ] monotonic-split ] map-literals ;
: upper-colon>form ( seq -- form )
[ first "syntax" lookup-word ] [ ] bi 2array ;
@ -318,4 +335,4 @@ M: object fixup-arity drop ;
: fixup-parse ( seq -- seq' )
core-syntax-forms
[ fixup-arity ] [ apply-decorators ] bi ;
[ fixup-arity ] [ apply-decorators2 ] bi ;

28
extra/modern/out/out.factor
View File

@ -85,6 +85,34 @@ DEFER: map-literals!
: map-literals! ( seq quot: ( obj -- obj' ) -- seq )
'[ _ map-literal! ] map! ; inline recursive
![[
GENERIC: split-to-sections ( seq -- seq' )
M: array split-to-sections ( seq -- seq' )
dup length 1 = [
[ dup section? [ split-to-sections ] when ] map
] [
[
[ nip dup section? [ split-to-sections ] when drop ]
[ [ section? ] either? not ] 2bi
] monotonic-split
] if ;
M: section split-to-sections ( seq -- seq' )
[ split-to-sections ] change-payload ;
GENERIC#: map-sections* 1 ( seq quot -- seq' )
M: section map-sections* ( seq quot -- seq' )
'[ _ ] change-payload ; inline recursive
M: array map-sections* ( seq quot -- seq' )
dup '[ dup section? [ _ map-sections* ] [ @ ] if ] map ; inline recursive
: map-sections ( seq quot -- seq' )
[ split-to-sections ] dip map-sections* ; inline
]]
: write-modern-string ( seq -- string )
[ write-literal ] with-string-writer ; inline