Merge branch 'master' of git://factorcode.org/git/factor
commit
4fd1547d37
|
@ -3,7 +3,7 @@
|
|||
!
|
||||
! Channels - based on ideas from newsqueak
|
||||
USING: kernel sequences sequences.lib threads continuations
|
||||
random math ;
|
||||
random math accessors ;
|
||||
IN: channels
|
||||
|
||||
TUPLE: channel receivers senders ;
|
||||
|
@ -17,14 +17,14 @@ GENERIC: from ( channel -- value )
|
|||
<PRIVATE
|
||||
|
||||
: wait ( channel -- )
|
||||
[ channel-senders push ] curry
|
||||
[ senders>> push ] curry
|
||||
"channel send" suspend drop ;
|
||||
|
||||
: (to) ( value receivers -- )
|
||||
delete-random resume-with yield ;
|
||||
|
||||
: notify ( continuation channel -- channel )
|
||||
[ channel-receivers push ] keep ;
|
||||
[ receivers>> push ] keep ;
|
||||
|
||||
: (from) ( senders -- )
|
||||
delete-random resume ;
|
||||
|
@ -32,11 +32,11 @@ GENERIC: from ( channel -- value )
|
|||
PRIVATE>
|
||||
|
||||
M: channel to ( value channel -- )
|
||||
dup channel-receivers
|
||||
dup receivers>>
|
||||
dup empty? [ drop dup wait to ] [ nip (to) ] if ;
|
||||
|
||||
M: channel from ( channel -- value )
|
||||
[
|
||||
notify channel-senders
|
||||
notify senders>>
|
||||
dup empty? [ drop ] [ (from) ] if
|
||||
] curry "channel receive" suspend ;
|
||||
|
|
|
@ -52,17 +52,17 @@ H{ } clone root-cache set-global
|
|||
SYMBOL: load-help?
|
||||
|
||||
: load-source ( vocab -- vocab )
|
||||
f >>source-loaded?
|
||||
f over set-vocab-source-loaded?
|
||||
[ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
|
||||
t >>source-loaded?
|
||||
t over set-vocab-source-loaded?
|
||||
[ [ % ] [ call ] if-bootstrapping ] dip ;
|
||||
|
||||
|
||||
: load-docs ( vocab -- vocab )
|
||||
load-help? get [
|
||||
f >>docs-loaded?
|
||||
f over set-vocab-docs-loaded?
|
||||
[ vocab-docs-path [ ?run-file ] when* ] keep
|
||||
t >>docs-loaded?
|
||||
t over set-vocab-docs-loaded?
|
||||
] when ;
|
||||
|
||||
: reload ( name -- )
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
USING: arrays asn1.ldap assocs byte-arrays combinators
|
||||
continuations io io.binary io.streams.string kernel math
|
||||
math.parser namespaces pack strings sequences ;
|
||||
math.parser namespaces pack strings sequences accessors ;
|
||||
|
||||
IN: asn1
|
||||
|
||||
|
@ -48,16 +48,12 @@ SYMBOL: elements
|
|||
|
||||
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
|
||||
|
||||
: <element> ( -- element ) element new ;
|
||||
|
||||
: set-id ( -- boolean )
|
||||
read1 dup elements get set-element-id ;
|
||||
|
||||
: get-id ( -- id )
|
||||
elements get element-id ;
|
||||
elements get id>> ;
|
||||
|
||||
: (set-tag) ( -- )
|
||||
elements get element-id 31 bitand
|
||||
elements get id>> 31 bitand
|
||||
dup elements get set-element-tag
|
||||
31 < [
|
||||
[ "unsupported tag encoding: #{" %
|
||||
|
@ -81,14 +77,14 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
|
|||
] unless elements get set-element-contentlength ;
|
||||
|
||||
: set-newobj ( -- )
|
||||
elements get element-contentlength read
|
||||
elements get contentlength>> read
|
||||
elements get set-element-newobj ;
|
||||
|
||||
: set-objtype ( syntax -- )
|
||||
builtin-syntax 2array [
|
||||
elements get element-tagclass swap at
|
||||
elements get element-encoding swap at
|
||||
elements get element-tag
|
||||
elements get tagclass>> swap at
|
||||
elements get encoding>> swap at
|
||||
elements get tag>>
|
||||
swap at [
|
||||
elements get set-element-objtype
|
||||
] when*
|
||||
|
@ -99,7 +95,7 @@ DEFER: read-ber
|
|||
SYMBOL: end
|
||||
|
||||
: (read-array) ( -- )
|
||||
elements get element-id [
|
||||
elements get id>> [
|
||||
elements get element-syntax read-ber
|
||||
dup end = [ drop ] [ , (read-array) ] if
|
||||
] when ;
|
||||
|
@ -115,9 +111,13 @@ SYMBOL: end
|
|||
{ "array" [ "" or [ read-array ] with-string-reader ] }
|
||||
} case ;
|
||||
|
||||
: set-id ( -- boolean )
|
||||
read1 dup elements get set-element-id ;
|
||||
|
||||
: read-ber ( syntax -- object )
|
||||
<element> elements set
|
||||
elements get set-element-syntax
|
||||
element new
|
||||
swap >>syntax
|
||||
elements set
|
||||
set-id [
|
||||
(set-tag)
|
||||
set-tagclass
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: math kernel debugger ;
|
||||
USING: accessors math kernel debugger ;
|
||||
IN: benchmark.fib4
|
||||
|
||||
TUPLE: box i ;
|
||||
|
@ -6,15 +6,15 @@ TUPLE: box i ;
|
|||
C: <box> box
|
||||
|
||||
: tuple-fib ( m -- n )
|
||||
dup box-i 1 <= [
|
||||
dup i>> 1 <= [
|
||||
drop 1 <box>
|
||||
] [
|
||||
box-i 1- <box>
|
||||
i>> 1- <box>
|
||||
dup tuple-fib
|
||||
swap
|
||||
box-i 1- <box>
|
||||
i>> 1- <box>
|
||||
tuple-fib
|
||||
swap box-i swap box-i + <box>
|
||||
swap i>> swap i>> + <box>
|
||||
] if ;
|
||||
|
||||
: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
USING: math kernel ;
|
||||
USING: math kernel accessors ;
|
||||
IN: benchmark.typecheck1
|
||||
|
||||
TUPLE: hello n ;
|
||||
|
||||
: foo ( obj -- obj n ) 0 100000000 [ over hello-n + ] times ;
|
||||
: foo ( obj -- obj n ) 0 100000000 [ over n>> + ] times ;
|
||||
|
||||
: typecheck-main ( -- ) 0 hello boa foo 2drop ;
|
||||
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: arrays combinators kernel lists math math.parser
|
|||
namespaces parser lexer parser-combinators parser-combinators.simple
|
||||
promises quotations sequences combinators.lib strings math.order
|
||||
assocs prettyprint.backend memoize unicode.case unicode.categories
|
||||
combinators.short-circuit ;
|
||||
combinators.short-circuit accessors ;
|
||||
USE: io
|
||||
IN: regexp
|
||||
|
||||
|
@ -277,7 +277,7 @@ TUPLE: regexp source parser ignore-case? ;
|
|||
|
||||
: match-head ( string regexp -- end )
|
||||
do-ignore-case regexp-parser parse dup nil?
|
||||
[ drop f ] [ car parse-result-unparsed slice-from ] if ;
|
||||
[ drop f ] [ car parse-result-unparsed from>> ] if ;
|
||||
|
||||
! Literal syntax for regexps
|
||||
: parse-options ( string -- ? )
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: xmode.loader xmode.utilities xmode.rules namespaces
|
||||
strings splitting assocs sequences kernel io.files xml memoize
|
||||
words globs combinators io.encodings.utf8 sorting ;
|
||||
words globs combinators io.encodings.utf8 sorting accessors ;
|
||||
IN: xmode.catalog
|
||||
|
||||
TUPLE: mode file file-name-glob first-line-glob ;
|
||||
|
@ -10,9 +10,9 @@ TUPLE: mode file file-name-glob first-line-glob ;
|
|||
TAG: MODE
|
||||
"NAME" over at >r
|
||||
mode new {
|
||||
{ "FILE" f set-mode-file }
|
||||
{ "FILE_NAME_GLOB" f set-mode-file-name-glob }
|
||||
{ "FIRST_LINE_GLOB" f set-mode-first-line-glob }
|
||||
{ "FILE" f (>>file) }
|
||||
{ "FILE_NAME_GLOB" f (>>file-name-glob) }
|
||||
{ "FIRST_LINE_GLOB" f (>>first-line-glob) }
|
||||
} init-from-tag r>
|
||||
rot set-at ;
|
||||
|
||||
|
@ -35,7 +35,7 @@ MEMO: mode-names ( -- modes )
|
|||
|
||||
MEMO: (load-mode) ( name -- rule-sets )
|
||||
modes at [
|
||||
mode-file
|
||||
file>>
|
||||
"resource:extra/xmode/modes/" prepend
|
||||
utf8 <file-reader> parse-mode
|
||||
] [
|
||||
|
@ -52,11 +52,11 @@ SYMBOL: rule-sets
|
|||
dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
|
||||
|
||||
: resolve-delegate ( rule -- )
|
||||
dup rule-delegate dup string?
|
||||
[ get-rule-set nip swap set-rule-delegate ] [ 2drop ] if ;
|
||||
dup delegate>> dup string?
|
||||
[ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ;
|
||||
|
||||
: each-rule ( rule-set quot -- )
|
||||
>r rule-set-rules values concat r> each ; inline
|
||||
>r rules>> values concat r> each ; inline
|
||||
|
||||
: resolve-delegates ( ruleset -- )
|
||||
[ resolve-delegate ] each-rule ;
|
||||
|
@ -65,14 +65,14 @@ SYMBOL: rule-sets
|
|||
over [ dupd update ] [ nip clone ] if ;
|
||||
|
||||
: import-keywords ( parent child -- )
|
||||
over >r [ rule-set-keywords ] bi@ ?update
|
||||
r> set-rule-set-keywords ;
|
||||
over >r [ keywords>> ] bi@ ?update
|
||||
r> (>>keywords) ;
|
||||
|
||||
: import-rules ( parent child -- )
|
||||
swap [ add-rule ] curry each-rule ;
|
||||
|
||||
: resolve-imports ( ruleset -- )
|
||||
dup rule-set-imports [
|
||||
dup imports>> [
|
||||
get-rule-set swap rule-sets [
|
||||
dup resolve-delegates
|
||||
2dup import-keywords
|
||||
|
@ -80,16 +80,19 @@ SYMBOL: rule-sets
|
|||
] with-variable
|
||||
] with each ;
|
||||
|
||||
ERROR: mutually-recursive-rulesets ruleset ;
|
||||
: finalize-rule-set ( ruleset -- )
|
||||
dup rule-set-finalized? {
|
||||
dup finalized?>> {
|
||||
{ f [
|
||||
1 over set-rule-set-finalized?
|
||||
dup resolve-imports
|
||||
dup resolve-delegates
|
||||
t swap set-rule-set-finalized?
|
||||
{
|
||||
[ 1 >>finalized? drop ]
|
||||
[ resolve-imports ]
|
||||
[ resolve-delegates ]
|
||||
[ t >>finalized? drop ]
|
||||
} cleave
|
||||
] }
|
||||
{ t [ drop ] }
|
||||
{ 1 [ "Mutually recursive rule sets" throw ] }
|
||||
{ 1 [ mutually-recursive-rulesets ] }
|
||||
} case ;
|
||||
|
||||
: finalize-mode ( rulesets -- )
|
||||
|
@ -107,8 +110,8 @@ SYMBOL: rule-sets
|
|||
dup [ glob-matches? ] [ 2drop f ] if ;
|
||||
|
||||
: suitable-mode? ( file-name first-line mode -- ? )
|
||||
tuck mode-first-line-glob ?glob-matches
|
||||
[ 2drop t ] [ mode-file-name-glob ?glob-matches ] if ;
|
||||
tuck first-line-glob>> ?glob-matches
|
||||
[ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
|
||||
|
||||
: find-mode ( file-name first-line -- mode )
|
||||
modes
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: xmode.loader.syntax xmode.tokens xmode.rules
|
||||
xmode.keyword-map xml.data xml.utilities xml assocs kernel
|
||||
combinators sequences math.parser namespaces parser
|
||||
xmode.utilities regexp io.files ;
|
||||
xmode.utilities regexp io.files accessors ;
|
||||
IN: xmode.loader
|
||||
|
||||
! Based on org.gjt.sp.jedit.XModeHandler
|
||||
|
@ -10,13 +10,13 @@ IN: xmode.loader
|
|||
<TAGS: parse-rule-tag ( rule-set tag -- )
|
||||
|
||||
TAG: PROPS
|
||||
parse-props-tag swap set-rule-set-props ;
|
||||
parse-props-tag >>props drop ;
|
||||
|
||||
TAG: IMPORT
|
||||
"DELEGATE" swap at swap import-rule-set ;
|
||||
|
||||
TAG: TERMINATE
|
||||
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ;
|
||||
"AT_CHAR" swap at string>number >>terminate-char drop ;
|
||||
|
||||
RULE: SEQ seq-rule
|
||||
shared-tag-attrs delegate-attr literal-start ;
|
||||
|
@ -45,7 +45,7 @@ RULE: MARK_PREVIOUS mark-previous-rule
|
|||
TAG: KEYWORDS ( rule-set tag -- key value )
|
||||
ignore-case? get <keyword-map>
|
||||
swap child-tags [ over parse-keyword-tag ] each
|
||||
swap set-rule-set-keywords ;
|
||||
swap (>>keywords) ;
|
||||
|
||||
TAGS>
|
||||
|
||||
|
@ -55,29 +55,29 @@ TAGS>
|
|||
: (parse-rules-tag) ( tag -- rule-set )
|
||||
<rule-set>
|
||||
{
|
||||
{ "SET" string>rule-set-name set-rule-set-name }
|
||||
{ "IGNORE_CASE" string>boolean set-rule-set-ignore-case? }
|
||||
{ "HIGHLIGHT_DIGITS" string>boolean set-rule-set-highlight-digits? }
|
||||
{ "DIGIT_RE" ?<regexp> set-rule-set-digit-re }
|
||||
{ "SET" string>rule-set-name (>>name) }
|
||||
{ "IGNORE_CASE" string>boolean (>>ignore-case?) }
|
||||
{ "HIGHLIGHT_DIGITS" string>boolean (>>highlight-digits?) }
|
||||
{ "DIGIT_RE" ?<regexp> (>>digit-re) }
|
||||
{ "ESCAPE" f add-escape-rule }
|
||||
{ "DEFAULT" string>token set-rule-set-default }
|
||||
{ "NO_WORD_SEP" f set-rule-set-no-word-sep }
|
||||
{ "DEFAULT" string>token (>>default) }
|
||||
{ "NO_WORD_SEP" f (>>no-word-sep) }
|
||||
} init-from-tag ;
|
||||
|
||||
: parse-rules-tag ( tag -- rule-set )
|
||||
dup (parse-rules-tag) [
|
||||
dup rule-set-ignore-case? ignore-case? [
|
||||
dup ignore-case?>> ignore-case? [
|
||||
swap child-tags [ parse-rule-tag ] with each
|
||||
] with-variable
|
||||
] keep ;
|
||||
|
||||
: merge-rule-set-props ( props rule-set -- )
|
||||
[ rule-set-props assoc-union ] keep set-rule-set-props ;
|
||||
[ assoc-union ] change-props drop ;
|
||||
|
||||
! Top-level entry points
|
||||
: parse-mode-tag ( tag -- rule-sets )
|
||||
dup "RULES" tags-named [
|
||||
parse-rules-tag dup rule-set-name swap
|
||||
parse-rules-tag dup name>> swap
|
||||
] H{ } map>assoc
|
||||
swap "PROPS" tag-named [
|
||||
parse-props-tag over values
|
||||
|
|
|
@ -49,41 +49,41 @@ SYMBOL: ignore-case?
|
|||
swap position-attrs <matcher> ;
|
||||
|
||||
: shared-tag-attrs ( -- )
|
||||
{ "TYPE" string>token set-rule-body-token } , ; inline
|
||||
{ "TYPE" string>token (>>body-token) } , ; inline
|
||||
|
||||
: delegate-attr ( -- )
|
||||
{ "DELEGATE" f set-rule-delegate } , ;
|
||||
{ "DELEGATE" f (>>delegate) } , ;
|
||||
|
||||
: regexp-attr ( -- )
|
||||
{ "HASH_CHAR" f set-rule-chars } , ;
|
||||
{ "HASH_CHAR" f (>>chars) } , ;
|
||||
|
||||
: match-type-attr ( -- )
|
||||
{ "MATCH_TYPE" string>match-type set-rule-match-token } , ;
|
||||
{ "MATCH_TYPE" string>match-type (>>match-token) } , ;
|
||||
|
||||
: span-attrs ( -- )
|
||||
{ "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } ,
|
||||
{ "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } ,
|
||||
{ "NO_ESCAPE" string>boolean set-rule-no-escape? } , ;
|
||||
{ "NO_LINE_BREAK" string>boolean (>>no-line-break?) } ,
|
||||
{ "NO_WORD_BREAK" string>boolean (>>no-word-break?) } ,
|
||||
{ "NO_ESCAPE" string>boolean (>>no-escape?) } , ;
|
||||
|
||||
: literal-start ( -- )
|
||||
[ parse-literal-matcher swap set-rule-start ] , ;
|
||||
[ parse-literal-matcher >>start drop ] , ;
|
||||
|
||||
: regexp-start ( -- )
|
||||
[ parse-regexp-matcher swap set-rule-start ] , ;
|
||||
[ parse-regexp-matcher >>start drop ] , ;
|
||||
|
||||
: literal-end ( -- )
|
||||
[ parse-literal-matcher swap set-rule-end ] , ;
|
||||
[ parse-literal-matcher >>end drop ] , ;
|
||||
|
||||
! SPAN's children
|
||||
<TAGS: parse-begin/end-tag ( rule tag -- )
|
||||
|
||||
TAG: BEGIN
|
||||
! XXX
|
||||
parse-literal-matcher swap set-rule-start ;
|
||||
parse-literal-matcher >>start drop ;
|
||||
|
||||
TAG: END
|
||||
! XXX
|
||||
parse-literal-matcher swap set-rule-end ;
|
||||
parse-literal-matcher >>end drop ;
|
||||
|
||||
TAGS>
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@ USING: kernel namespaces xmode.rules xmode.tokens
|
|||
xmode.marker.state xmode.marker.context xmode.utilities
|
||||
xmode.catalog sequences math assocs combinators combinators.lib
|
||||
strings regexp splitting parser-combinators ascii unicode.case
|
||||
combinators.short-circuit ;
|
||||
combinators.short-circuit accessors ;
|
||||
|
||||
! Based on org.gjt.sp.jedit.syntax.TokenMarker
|
||||
|
||||
|
@ -12,11 +12,11 @@ combinators.short-circuit ;
|
|||
|
||||
: keyword-number? ( keyword -- ? )
|
||||
{
|
||||
[ current-rule-set rule-set-highlight-digits? ]
|
||||
[ current-rule-set highlight-digits?>> ]
|
||||
[ dup [ digit? ] contains? ]
|
||||
[
|
||||
dup [ digit? ] all? [
|
||||
current-rule-set rule-set-digit-re
|
||||
current-rule-set digit-re>>
|
||||
dup [ dupd matches? ] [ drop f ] if
|
||||
] unless*
|
||||
]
|
||||
|
@ -26,10 +26,10 @@ combinators.short-circuit ;
|
|||
keyword-number? DIGIT and ;
|
||||
|
||||
: mark-keyword ( keyword -- id )
|
||||
current-rule-set rule-set-keywords at ;
|
||||
current-rule-set keywords>> at ;
|
||||
|
||||
: add-remaining-token ( -- )
|
||||
current-rule-set rule-set-default prev-token, ;
|
||||
current-rule-set default>> prev-token, ;
|
||||
|
||||
: mark-token ( -- )
|
||||
current-keyword
|
||||
|
@ -48,9 +48,9 @@ M: rule match-position drop position get ;
|
|||
: can-match-here? ( matcher rule -- ? )
|
||||
match-position {
|
||||
[ over ]
|
||||
[ over matcher-at-line-start? over zero? implies ]
|
||||
[ over matcher-at-whitespace-end? over whitespace-end get = implies ]
|
||||
[ over matcher-at-word-start? over last-offset get = implies ]
|
||||
[ over at-line-start?>> over zero? implies ]
|
||||
[ over at-whitespace-end?>> over whitespace-end get = implies ]
|
||||
[ over at-word-start?>> over last-offset get = implies ]
|
||||
} 0&& 2nip ;
|
||||
|
||||
: rest-of-line ( -- str )
|
||||
|
@ -72,19 +72,19 @@ M: regexp text-matches?
|
|||
>r >string r> match-head ;
|
||||
|
||||
: rule-start-matches? ( rule -- match-count/f )
|
||||
dup rule-start tuck swap can-match-here? [
|
||||
rest-of-line swap matcher-text text-matches?
|
||||
dup start>> tuck swap can-match-here? [
|
||||
rest-of-line swap text>> text-matches?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: rule-end-matches? ( rule -- match-count/f )
|
||||
dup mark-following-rule? [
|
||||
dup rule-start swap can-match-here? 0 and
|
||||
dup start>> swap can-match-here? 0 and
|
||||
] [
|
||||
dup rule-end tuck swap can-match-here? [
|
||||
dup end>> tuck swap can-match-here? [
|
||||
rest-of-line
|
||||
swap matcher-text context get line-context-end or
|
||||
swap text>> context get end>> or
|
||||
text-matches?
|
||||
] [
|
||||
drop f
|
||||
|
@ -94,10 +94,10 @@ M: regexp text-matches?
|
|||
DEFER: get-rules
|
||||
|
||||
: get-always-rules ( vector/f ruleset -- vector/f )
|
||||
f swap rule-set-rules at ?push-all ;
|
||||
f swap rules>> at ?push-all ;
|
||||
|
||||
: get-char-rules ( vector/f char ruleset -- vector/f )
|
||||
>r ch>upper r> rule-set-rules at ?push-all ;
|
||||
>r ch>upper r> rules>> at ?push-all ;
|
||||
|
||||
: get-rules ( char ruleset -- seq )
|
||||
f -rot [ get-char-rules ] keep get-always-rules ;
|
||||
|
@ -108,13 +108,13 @@ GENERIC: handle-rule-end ( match-count rule -- )
|
|||
|
||||
: find-escape-rule ( -- rule )
|
||||
context get dup
|
||||
line-context-in-rule-set rule-set-escape-rule [ ] [
|
||||
line-context-parent line-context-in-rule-set
|
||||
dup [ rule-set-escape-rule ] when
|
||||
in-rule-set>> escape-rule>> [ ] [
|
||||
parent>> in-rule-set>>
|
||||
dup [ escape-rule>> ] when
|
||||
] ?if ;
|
||||
|
||||
: check-escape-rule ( rule -- ? )
|
||||
rule-no-escape? [ f ] [
|
||||
no-escape?>> [ f ] [
|
||||
find-escape-rule dup [
|
||||
dup rule-start-matches? dup [
|
||||
swap handle-rule-start
|
||||
|
@ -138,9 +138,9 @@ GENERIC: handle-rule-end ( match-count rule -- )
|
|||
] when* ;
|
||||
|
||||
: rule-match-token* ( rule -- id )
|
||||
dup rule-match-token {
|
||||
{ f [ dup rule-body-token ] }
|
||||
{ t [ current-rule-set rule-set-default ] }
|
||||
dup match-token>> {
|
||||
{ f [ dup body-token>> ] }
|
||||
{ t [ current-rule-set default>> ] }
|
||||
[ ]
|
||||
} case nip ;
|
||||
|
||||
|
@ -156,8 +156,8 @@ M: seq-rule handle-rule-start
|
|||
?end-rule
|
||||
mark-token
|
||||
add-remaining-token
|
||||
tuck rule-body-token next-token,
|
||||
rule-delegate [ push-context ] when* ;
|
||||
tuck body-token>> next-token,
|
||||
delegate>> [ push-context ] when* ;
|
||||
|
||||
UNION: abstract-span-rule span-rule eol-span-rule ;
|
||||
|
||||
|
@ -167,8 +167,8 @@ M: abstract-span-rule handle-rule-start
|
|||
add-remaining-token
|
||||
tuck rule-match-token* next-token,
|
||||
! ... end subst ...
|
||||
dup context get set-line-context-in-rule
|
||||
rule-delegate push-context ;
|
||||
dup context get (>>in-rule)
|
||||
delegate>> push-context ;
|
||||
|
||||
M: span-rule handle-rule-end
|
||||
2drop ;
|
||||
|
@ -197,15 +197,16 @@ M: mark-previous-rule handle-rule-start
|
|||
] when ;
|
||||
|
||||
: check-end-delegate ( -- ? )
|
||||
context get line-context-parent [
|
||||
line-context-in-rule [
|
||||
context get parent>> [
|
||||
in-rule>> [
|
||||
dup rule-end-matches? dup [
|
||||
[
|
||||
swap handle-rule-end
|
||||
?end-rule
|
||||
mark-token
|
||||
add-remaining-token
|
||||
] keep context get line-context-parent line-context-in-rule rule-match-token* next-token,
|
||||
] keep context get parent>> in-rule>>
|
||||
rule-match-token* next-token,
|
||||
pop-context
|
||||
seen-whitespace-end? on t
|
||||
] [ drop check-escape-rule ] if
|
||||
|
@ -213,9 +214,9 @@ M: mark-previous-rule handle-rule-start
|
|||
] [ f ] if* ;
|
||||
|
||||
: handle-no-word-break ( -- )
|
||||
context get line-context-parent [
|
||||
line-context-in-rule [
|
||||
dup rule-no-word-break? [
|
||||
context get parent>> [
|
||||
in-rule>> [
|
||||
dup no-word-break?>> [
|
||||
rule-match-token* prev-token,
|
||||
pop-context
|
||||
] [ drop ] if
|
||||
|
@ -231,11 +232,11 @@ M: mark-previous-rule handle-rule-start
|
|||
: (check-word-break) ( -- )
|
||||
check-rule
|
||||
|
||||
1 current-rule-set rule-set-default next-token, ;
|
||||
1 current-rule-set default>> next-token, ;
|
||||
|
||||
: rule-set-empty? ( ruleset -- ? )
|
||||
dup rule-set-rules assoc-empty?
|
||||
swap rule-set-keywords assoc-empty? and ;
|
||||
[ rules>> ] [ keywords>> ] bi
|
||||
[ assoc-empty? ] bi@ and ;
|
||||
|
||||
: check-word-break ( -- ? )
|
||||
current-char dup blank? [
|
||||
|
@ -285,9 +286,9 @@ M: mark-previous-rule handle-rule-start
|
|||
check-rule ;
|
||||
|
||||
: unwind-no-line-break ( -- )
|
||||
context get line-context-parent [
|
||||
line-context-in-rule [
|
||||
rule-no-line-break? [
|
||||
context get parent>> [
|
||||
in-rule>> [
|
||||
no-line-break?>> [
|
||||
pop-context
|
||||
unwind-no-line-break
|
||||
] when
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: xmode.marker.context xmode.rules symbols
|
||||
USING: xmode.marker.context xmode.rules symbols accessors
|
||||
xmode.tokens namespaces kernel sequences assocs math ;
|
||||
IN: xmode.marker.state
|
||||
|
||||
|
@ -9,13 +9,13 @@ SYMBOLS: line last-offset position context
|
|||
escaped? process-escape? delegate-end-escaped? ;
|
||||
|
||||
: current-rule ( -- rule )
|
||||
context get line-context-in-rule ;
|
||||
context get in-rule>> ;
|
||||
|
||||
: current-rule-set ( -- rule )
|
||||
context get line-context-in-rule-set ;
|
||||
context get in-rule-set>> ;
|
||||
|
||||
: current-keywords ( -- keyword-map )
|
||||
current-rule-set rule-set-keywords ;
|
||||
current-rule-set keywords>> ;
|
||||
|
||||
: token, ( from to id -- )
|
||||
2over = [ 3drop ] [ >r line get subseq r> <token> , ] if ;
|
||||
|
@ -32,9 +32,8 @@ SYMBOLS: line last-offset position context
|
|||
context [ <line-context> ] change ;
|
||||
|
||||
: pop-context ( -- )
|
||||
context get line-context-parent
|
||||
dup context set
|
||||
f swap set-line-context-in-rule ;
|
||||
context get parent>>
|
||||
f >>in-rule context set ;
|
||||
|
||||
: init-token-marker ( main prev-context line -- )
|
||||
line set
|
||||
|
|
|
@ -30,10 +30,10 @@ finalized?
|
|||
V{ } clone >>imports ;
|
||||
|
||||
MEMO: standard-rule-set ( id -- ruleset )
|
||||
<rule-set> [ set-rule-set-default ] keep ;
|
||||
<rule-set> swap >>default ;
|
||||
|
||||
: import-rule-set ( import ruleset -- )
|
||||
rule-set-imports push ;
|
||||
imports>> push ;
|
||||
|
||||
: inverted-index ( hashes key index -- )
|
||||
[ swapd push-at ] 2curry each ;
|
||||
|
@ -44,8 +44,9 @@ MEMO: standard-rule-set ( id -- ruleset )
|
|||
] when* ;
|
||||
|
||||
: rule-set-no-word-sep* ( ruleset -- str )
|
||||
dup rule-set-no-word-sep
|
||||
swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when
|
||||
[ no-word-sep>> ]
|
||||
[ keywords>> ] bi
|
||||
dup [ keyword-map-no-word-sep* ] when
|
||||
"_" 3append ;
|
||||
|
||||
! Match restrictions
|
||||
|
@ -73,14 +74,14 @@ TUPLE: span-rule < rule ;
|
|||
TUPLE: eol-span-rule < rule ;
|
||||
|
||||
: init-span ( rule -- )
|
||||
dup rule-delegate [ drop ] [
|
||||
dup rule-body-token standard-rule-set
|
||||
swap set-rule-delegate
|
||||
dup delegate>> [ drop ] [
|
||||
dup body-token>> standard-rule-set
|
||||
swap (>>delegate)
|
||||
] if ;
|
||||
|
||||
: init-eol-span ( rule -- )
|
||||
dup init-span
|
||||
t swap set-rule-no-line-break? ;
|
||||
t >>no-line-break? drop ;
|
||||
|
||||
TUPLE: mark-following-rule < rule ;
|
||||
|
||||
|
@ -101,18 +102,17 @@ M: string-matcher text-hash-char string-matcher-string first ;
|
|||
M: regexp text-hash-char drop f ;
|
||||
|
||||
: rule-chars* ( rule -- string )
|
||||
dup rule-chars
|
||||
swap rule-start matcher-text
|
||||
[ chars>> ] [ start>> ] bi text>>
|
||||
text-hash-char [ suffix ] when* ;
|
||||
|
||||
: add-rule ( rule ruleset -- )
|
||||
>r dup rule-chars* >upper swap
|
||||
r> rule-set-rules inverted-index ;
|
||||
r> rules>> inverted-index ;
|
||||
|
||||
: add-escape-rule ( string ruleset -- )
|
||||
over [
|
||||
>r <escape-rule> r>
|
||||
2dup set-rule-set-escape-rule
|
||||
[ <escape-rule> ] dip
|
||||
2dup (>>escape-rule)
|
||||
add-rule
|
||||
] [
|
||||
2drop
|
||||
|
|
|
@ -14,7 +14,7 @@ TUPLE: company employees type ;
|
|||
|
||||
: <company> V{ } clone f company boa ;
|
||||
|
||||
: add-employee company-employees push ;
|
||||
: add-employee employees>> push ;
|
||||
|
||||
<TAGS: parse-employee-tag
|
||||
|
||||
|
@ -22,7 +22,7 @@ TUPLE: employee name description ;
|
|||
|
||||
TAG: employee
|
||||
employee new
|
||||
{ { "name" f set-employee-name } { f set-employee-description } }
|
||||
{ { "name" f (>>name) } { f (>>description) } }
|
||||
init-from-tag swap add-employee ;
|
||||
|
||||
TAGS>
|
||||
|
@ -32,7 +32,7 @@ TAGS>
|
|||
: parse-company-tag
|
||||
[
|
||||
<company>
|
||||
{ { "type" >upper set-company-type } }
|
||||
{ { "type" >upper (>>type) } }
|
||||
init-from-tag dup
|
||||
] keep
|
||||
children>> [ tag? ] filter
|
||||
|
|
Loading…
Reference in New Issue