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

modern.out: messing with arity.

locals-and-roots
Doug Coleman 2016-06-27 20:45:34 -07:00
parent c1c08dda52
commit e0b5ddb07c
1 changed files with 13 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
core/modern/out/out.factor
View File

@ -48,7 +48,6 @@ CONSTANT: janky-arities H{
`HOOK 3 `HOOK 3
} ; } ;
DEFER: write-literal
GENERIC: write-literal ( obj -- ) ; GENERIC: write-literal ( obj -- ) ;
! M: object write-literal lexed-underlying write ; ! M: object write-literal lexed-underlying write ;
M: string write-literal write ; M: string write-literal write ;
@ -234,22 +233,24 @@ M: compound-sequence-literal write-literal
] if ; inline recursive ] if ; inline recursive
GENERIC: split-arity ( obj -- seq ) ; GENERIC: fixup-arity ( obj -- seq ) ;
M: uppercase-colon-literal split-arity ERROR: closing-tag-required2 obj ;
dup { [ uppercase-colon-literal? ] [ tag>> janky-arities at ] } 1&& [ M: uppercase-colon-literal fixup-arity
dup tag>> janky-arities at dup tag>> janky-arities ?at [
$[ _ swap [ any-comment? not ] cut-nth-match swap ] change-payload $[ _ swap [ any-comment? not ] cut-nth-match swap ] change-payload
swap 2array swap 2array
dup first f >>closing-tag drop dup first f >>closing-tag drop
! dup first " ;" >>closing-tag drop ! dup first " ;" >>closing-tag drop
] when ; ] [
drop
dup closing-tag>> [ closing-tag-required2 ] unless
] if ;
M: less-than-literal split-arity M: less-than-literal fixup-arity
[ [ split-arity ] map ] change-payload ; [ [ fixup-arity ] map ] change-payload ;
M: object split-arity ;
M: object fixup-arity ;
: rewrite-path ( path quot -- ) : rewrite-path ( path quot -- )
! dup print ! dup print
@ -257,7 +258,7 @@ M: object split-arity ;
[ [
path>literals path>literals
[ _ map-literals ] map [ _ map-literals ] map
[ split-arity ] map [ fixup-arity ] map
] [ ] bi write-modern-path ] ] [ ] bi write-modern-path ]
[ drop . ] recover ; inline [ drop . ] recover ; inline
@ -265,7 +266,7 @@ M: object split-arity ;
! dup print ! dup print
[ string>literals ] dip $[ _ map-literals ] map [ string>literals ] dip $[ _ map-literals ] map
! colons ! colons
[ split-arity ] map [ fixup-arity ] map
write-modern-string ; inline write-modern-string ; inline
: rewrite-paths ( seq quot -- ) $[ _ rewrite-path ] each ; inline : rewrite-paths ( seq quot -- ) $[ _ rewrite-path ] each ; inline