From 4a887d355fd8e0129c546ef5d56bae245eabb5e7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 20:32:26 -0500
Subject: [PATCH 1/7] partial update of xmode for new accessors
---
extra/xmode/catalog/catalog.factor | 29 ++++----
extra/xmode/loader/loader.factor | 20 +++---
extra/xmode/marker/marker.factor | 69 ++++++++++----------
extra/xmode/marker/state/state.factor | 11 ++--
extra/xmode/rules/rules.factor | 18 ++---
extra/xmode/utilities/utilities-tests.factor | 6 +-
6 files changed, 77 insertions(+), 76 deletions(-)
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 98276caf83..e85188e82d 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -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
] [
@@ -72,7 +72,7 @@ SYMBOL: rule-sets
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,17 @@ 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?
+ [ resolve-imports ]
+ [ resolve-delegates ] bi
+ t >>finalized? drop
] }
{ t [ drop ] }
- { 1 [ "Mutually recursive rule sets" throw ] }
+ { 1 [ mutually-recursive-rulesets ] }
} case ;
: finalize-mode ( rulesets -- )
@@ -107,8 +108,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
diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor
index 8039db0ac9..11e10cc5e4 100755
--- a/extra/xmode/loader/loader.factor
+++ b/extra/xmode/loader/loader.factor
@@ -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 ;
@@ -55,18 +55,18 @@ 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 ;
diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor
index 911397cc20..60543c0504 100755
--- a/extra/xmode/marker/marker.factor
+++ b/extra/xmode/marker/marker.factor
@@ -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 )
@@ -73,18 +73,18 @@ M: regexp text-matches?
: rule-start-matches? ( rule -- match-count/f )
dup rule-start tuck swap can-match-here? [
- rest-of-line swap matcher-text text-matches?
+ 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,9 +108,9 @@ 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 -- ? )
@@ -138,9 +138,9 @@ GENERIC: handle-rule-end ( match-count rule -- )
] when* ;
: rule-match-token* ( rule -- id )
- dup rule-match-token {
+ dup match-token>> {
{ f [ dup rule-body-token ] }
- { t [ current-rule-set rule-set-default ] }
+ { 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,8 +214,8 @@ M: mark-previous-rule handle-rule-start
] [ f ] if* ;
: handle-no-word-break ( -- )
- context get line-context-parent [
- line-context-in-rule [
+ context get parent>> [
+ in-rule>> [
dup rule-no-word-break? [
rule-match-token* prev-token,
pop-context
@@ -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
diff --git a/extra/xmode/marker/state/state.factor b/extra/xmode/marker/state/state.factor
index 2cf12f301d..4faa3a4f59 100755
--- a/extra/xmode/marker/state/state.factor
+++ b/extra/xmode/marker/state/state.factor
@@ -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,10 +9,10 @@ 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 ;
@@ -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
diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor
index 50d2924b61..1a2a99c956 100755
--- a/extra/xmode/rules/rules.factor
+++ b/extra/xmode/rules/rules.factor
@@ -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
@@ -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
diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor
index 49a1265b09..e4946701dd 100755
--- a/extra/xmode/utilities/utilities-tests.factor
+++ b/extra/xmode/utilities/utilities-tests.factor
@@ -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
From 6fe6475cce47b99f47192fc75e4673869c47077c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 20:37:55 -0500
Subject: [PATCH 2/7] fix bug
---
extra/xmode/catalog/catalog.factor | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index e85188e82d..092eced330 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -84,10 +84,12 @@ ERROR: mutually-recursive-rulesets ruleset ;
: finalize-rule-set ( ruleset -- )
dup finalized?>> {
{ f [
- 1 >>finalized?
- [ resolve-imports ]
- [ resolve-delegates ] bi
- t >>finalized? drop
+ {
+ [ 1 >>finalized? drop ]
+ [ resolve-imports ]
+ [ resolve-delegates ]
+ [ t >>finalized? drop ]
+ } cleave
] }
{ t [ drop ] }
{ 1 [ mutually-recursive-rulesets ] }
From 6bd16d7f9fa7fd42b17a17824e7ac0118a6098d3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 20:38:07 -0500
Subject: [PATCH 3/7] new accessors
---
extra/asn1/asn1.factor | 28 ++++++++++----------
extra/benchmark/fib4/fib4.factor | 10 +++----
extra/benchmark/typecheck1/typecheck1.factor | 4 +--
extra/regexp/regexp.factor | 4 +--
4 files changed, 23 insertions(+), 23 deletions(-)
diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor
index 7b46aa87de..3509deb2fb 100644
--- a/extra/asn1/asn1.factor
+++ b/extra/asn1/asn1.factor
@@ -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
diff --git a/extra/benchmark/fib4/fib4.factor b/extra/benchmark/fib4/fib4.factor
index 7cf756e11f..580be0d0ec 100644
--- a/extra/benchmark/fib4/fib4.factor
+++ b/extra/benchmark/fib4/fib4.factor
@@ -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= ;
diff --git a/extra/benchmark/typecheck1/typecheck1.factor b/extra/benchmark/typecheck1/typecheck1.factor
index 434094a2a3..5ffe96292b 100644
--- a/extra/benchmark/typecheck1/typecheck1.factor
+++ b/extra/benchmark/typecheck1/typecheck1.factor
@@ -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 ;
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index c329977875..1bd81d46ea 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -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 -- ? )
From 91d3f64ab2571b98e079b151e80d1e20341f9244 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 20:38:18 -0500
Subject: [PATCH 4/7] new accessors
---
basis/channels/channels.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor
index ea54766ad4..9b5cbee04b 100755
--- a/basis/channels/channels.factor
+++ b/basis/channels/channels.factor
@@ -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 ;
From 6ed00241b694de45c1dd469b5585cf17ec8a8037 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 20:53:59 -0500
Subject: [PATCH 5/7] more accessors
---
extra/xmode/catalog/catalog.factor | 6 +++---
extra/xmode/loader/loader.factor | 4 ++--
extra/xmode/loader/syntax/syntax.factor | 24 ++++++++++++------------
3 files changed, 17 insertions(+), 17 deletions(-)
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 092eced330..605d6742c8 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -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 ;
diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor
index 11e10cc5e4..442693025e 100755
--- a/extra/xmode/loader/loader.factor
+++ b/extra/xmode/loader/loader.factor
@@ -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>
@@ -72,7 +72,7 @@ TAGS>
] 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 )
diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor
index 8b66774d7f..5512b68b04 100644
--- a/extra/xmode/loader/syntax/syntax.factor
+++ b/extra/xmode/loader/syntax/syntax.factor
@@ -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>
From 9695df7fbd8f7bd41653fc450279b1bbb6d64f9d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:01:54 -0500
Subject: [PATCH 6/7] fix loader bug i introduced
---
core/vocabs/loader/loader.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 8609cb5b5f..522e7d74c3 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -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 -- )
From 34b2db96ef5a674b07cba80084ea874e48fec526 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 30 Aug 2008 21:10:02 -0500
Subject: [PATCH 7/7] new accessors ftw
---
extra/xmode/catalog/catalog.factor | 4 ++--
extra/xmode/loader/loader.factor | 2 +-
extra/xmode/marker/marker.factor | 8 ++++----
extra/xmode/marker/state/state.factor | 2 +-
extra/xmode/rules/rules.factor | 8 ++++----
5 files changed, 12 insertions(+), 12 deletions(-)
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 605d6742c8..26147c7867 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -65,8 +65,8 @@ 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 ;
diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor
index 442693025e..28c0de406a 100755
--- a/extra/xmode/loader/loader.factor
+++ b/extra/xmode/loader/loader.factor
@@ -77,7 +77,7 @@ TAGS>
! 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
diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor
index 60543c0504..707449a23f 100755
--- a/extra/xmode/marker/marker.factor
+++ b/extra/xmode/marker/marker.factor
@@ -72,7 +72,7 @@ M: regexp text-matches?
>r >string r> match-head ;
: rule-start-matches? ( rule -- match-count/f )
- dup rule-start tuck swap can-match-here? [
+ dup start>> tuck swap can-match-here? [
rest-of-line swap text>> text-matches?
] [
drop f
@@ -114,7 +114,7 @@ GENERIC: handle-rule-end ( match-count rule -- )
] ?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
@@ -139,7 +139,7 @@ GENERIC: handle-rule-end ( match-count rule -- )
: rule-match-token* ( rule -- id )
dup match-token>> {
- { f [ dup rule-body-token ] }
+ { f [ dup body-token>> ] }
{ t [ current-rule-set default>> ] }
[ ]
} case nip ;
@@ -216,7 +216,7 @@ M: mark-previous-rule handle-rule-start
: handle-no-word-break ( -- )
context get parent>> [
in-rule>> [
- dup rule-no-word-break? [
+ dup no-word-break?>> [
rule-match-token* prev-token,
pop-context
] [ drop ] if
diff --git a/extra/xmode/marker/state/state.factor b/extra/xmode/marker/state/state.factor
index 4faa3a4f59..9075ff6329 100755
--- a/extra/xmode/marker/state/state.factor
+++ b/extra/xmode/marker/state/state.factor
@@ -15,7 +15,7 @@ SYMBOLS: line last-offset position context
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 ;
diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor
index 1a2a99c956..4ab45d7539 100755
--- a/extra/xmode/rules/rules.factor
+++ b/extra/xmode/rules/rules.factor
@@ -74,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 ;