62 lines
2.3 KiB
Factor
62 lines
2.3 KiB
Factor
|
! Copyright (C) 2018 Doug Coleman.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: assocs combinators kernel namespaces sequences splitting
|
||
|
|
strings strings.parser ;
|
||
|
|
IN: syntax.modern
|
||
|
|
|
||
|
|
INITIALIZED-SYMBOL: single-quote-definitions [ H{ } clone ]
|
||
|
|
INITIALIZED-SYMBOL: lower-colon-definitions [ H{ } clone ]
|
||
|
|
INITIALIZED-SYMBOL: upper-colon-definitions [ H{ } clone ]
|
||
|
|
INITIALIZED-SYMBOL: double-quote-definitions [ H{ } clone ]
|
||
|
|
INITIALIZED-SYMBOL: bracket-container-definitions [ H{ } clone ]
|
||
|
|
INITIALIZED-SYMBOL: brace-container-definitions [ H{ } clone ]
|
||
|
|
INITIALIZED-SYMBOL: paren-container-definitions [ H{ } clone ]
|
||
|
|
|
||
|
|
: define-single-quote-word ( word def -- ) swap lower-colon-definitions get set-at ;
|
||
|
|
: define-lower-colon-word ( word def -- ) swap lower-colon-definitions get set-at ;
|
||
|
|
: define-upper-colon-word ( word def -- ) swap upper-colon-definitions get set-at ;
|
||
|
|
: define-double-quote-word ( word def -- ) swap double-quote-definitions get set-at ;
|
||
|
|
: define-bracket-container-word ( word def -- ) swap bracket-container-definitions get set-at ;
|
||
|
|
: define-brace-container-word ( word def -- ) swap brace-container-definitions get set-at ;
|
||
|
|
: define-paren-container-word ( word def -- ) swap paren-container-definitions get set-at ;
|
||
|
|
|
||
|
|
GENERIC: lower-colon>object ( obj -- obj' )
|
||
|
|
GENERIC: double-quote>object ( obj -- obj' )
|
||
|
|
GENERIC: bracket-container>object ( obj -- obj' )
|
||
|
|
GENERIC: brace-container>object ( obj -- obj' )
|
||
|
|
GENERIC: paren-container>object ( obj -- obj' )
|
||
|
|
|
||
|
|
![[
|
||
|
|
SYNTAX: LOWER-COLON:
|
||
|
|
scan-new-class
|
||
|
|
[ ]
|
||
|
|
[ tuple { "object" } define-tuple-class ]
|
||
|
|
[ '[ _ boa suffix! ] define-lower-colon-word ] tri ;
|
||
|
|
]]
|
||
|
|
|
||
|
|
|
||
|
|
ERROR: no-single-quote-word payload word ;
|
||
|
|
: handle-single-quote ( pair -- obj )
|
||
|
|
first2 swap single-quote-definitions get ?at
|
||
|
|
[ execute( obj -- obj' ) ]
|
||
|
|
[ no-single-quote-word ] if ;
|
||
|
|
|
||
|
|
: ch>object ( ch -- obj )
|
||
|
|
{
|
||
|
|
{ [ dup length 1 = ] [ first ] }
|
||
|
|
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
|
||
|
|
[ name>char-hook get ( name -- char ) call-effect ]
|
||
|
|
} cond ;
|
||
|
|
|
||
|
|
\ ch>object "ch" single-quote-definitions get set-at
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
ERROR: no-lower-colon-word payload word ;
|
||
|
|
: handle-lower-colon ( pair -- obj )
|
||
|
|
first2 swap lower-colon-definitions get ?at
|
||
|
|
[ execute( obj -- obj' ) ]
|
||
|
|
[ no-lower-colon-word ] if ;
|
||
|
|
|
||
|
|
: no-op ( obj -- obj' ) ;
|
||
|
|
\ no-op "data-stack" lower-colon-definitions get set-at
|