From 98c2548fa3e66d4fc3e52c8ea492af99dd0f5ac4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:19:06 -0500 Subject: [PATCH 01/17] new accessors --- basis/concurrency/locks/locks-tests.factor | 2 +- basis/concurrency/locks/locks.factor | 45 +++++++++++----------- 2 files changed, 23 insertions(+), 24 deletions(-) diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 92dede1655..67f9bbb15a 100755 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -174,7 +174,7 @@ threads sequences calendar accessors ; ] ; [ lock-timeout-test ] [ - linked-error-thread name>> "Lock timeout-er" = + thread>> name>> "Lock timeout-er" = ] must-fail-with :: read/write-test ( -- ) diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 95b6801db2..8c1392dbfb 100755 --- a/basis/concurrency/locks/locks.factor +++ b/basis/concurrency/locks/locks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: deques dlists kernel threads continuations math -concurrency.conditions ; +concurrency.conditions combinators.short-circuit accessors ; IN: concurrency.locks ! Simple critical sections @@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ; r lock-threads r> "lock" wait ] when drop - self swap set-lock-owner ; + over owner>> + [ 2dup >r threads>> r> "lock" wait ] when drop + self >>owner drop ; : release-lock ( lock -- ) - f over set-lock-owner - lock-threads notify-1 ; + f >>owner + threads>> notify-1 ; : do-lock ( lock timeout quot acquire release -- ) >r >r pick rot r> call ! use up timeout acquire @@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ; PRIVATE> : with-lock-timeout ( lock timeout quot -- ) - pick lock-reentrant? [ - pick lock-owner self eq? [ + pick reentrant?>> [ + pick owner>> self eq? [ 2nip call ] [ (with-lock) @@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> "read lock" wait ] when drop + over writer>> + [ 2dup >r readers>> r> "read lock" wait ] when drop add-reader ; : notify-writer ( lock -- ) - rw-lock-writers notify-1 ; + writers>> notify-1 ; : remove-reader ( lock -- ) - dup rw-lock-reader# 1- swap set-rw-lock-reader# ; + [ 1- ] change-reader# drop ; : release-read-lock ( lock -- ) dup remove-reader - dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; + dup reader#>> zero? [ notify-writer ] [ drop ] if ; : acquire-write-lock ( lock timeout -- ) - over rw-lock-writer pick rw-lock-reader# 0 > or - [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop - self swap set-rw-lock-writer ; + over writer>> pick reader#>> 0 > or + [ 2dup >r writers>> r> "write lock" wait ] when drop + self >>writer drop ; : release-write-lock ( lock -- ) - f over set-rw-lock-writer - dup rw-lock-readers deque-empty? - [ notify-writer ] [ rw-lock-readers notify-all ] if ; + f >>writer + dup readers>> deque-empty? + [ notify-writer ] [ readers>> notify-all ] if ; : reentrant-read-lock-ok? ( lock -- ? ) #! If we already have a write lock, then we can grab a read #! lock too. - rw-lock-writer self eq? ; + writer>> self eq? ; : reentrant-write-lock-ok? ( lock -- ? ) #! The only case where we have a writer and > 1 reader is #! write -> read re-entrancy, and in this case we prohibit #! a further write -> read -> write re-entrancy. - dup rw-lock-writer self eq? - swap rw-lock-reader# zero? and ; + { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ; PRIVATE> From 754d68fb958a1ec3f7ae3a60bd2dc64b7a5d5bc5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:22:29 -0500 Subject: [PATCH 02/17] new accessors --- extra/turing/turing.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/turing/turing.factor b/extra/turing/turing.factor index f5b510237b..18d66a2e51 100644 --- a/extra/turing/turing.factor +++ b/extra/turing/turing.factor @@ -1,6 +1,6 @@ -IN: turing USING: arrays assocs io kernel math namespaces -prettyprint sequences strings vectors words ; +prettyprint sequences strings vectors words accessors ; +IN: turing ! A turing machine simulator. @@ -55,9 +55,9 @@ SYMBOL: tape : turing-step ( -- ) #! Do one step of the turing machine. next-state - dup state-sym set-sym - dup state-dir position [ + ] change - state-next state set ; + dup sym>> set-sym + dup dir>> position [ + ] change + next>> state set ; : c ( -- ) #! Print current turing machine state. From 3f82d8eb9e8a196b29a9ed0a642e080f28c8e440 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:25:47 -0500 Subject: [PATCH 03/17] no unit tests?? new accessors --- extra/state-machine/state-machine.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index b5e8c16b02..6a785e91b7 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -1,5 +1,6 @@ -USING: kernel parser lexer strings math namespaces sequences words io -arrays quotations debugger kernel.private sequences.private ; +USING: kernel parser lexer strings math namespaces +sequences words io arrays quotations debugger accessors +sequences.private ; IN: state-machine : STATES: @@ -20,9 +21,9 @@ M: missing-state error. ! quot is ( state string -- output-string ) [ missing-state ] dup [ - [ >r dup dup state-data swap state-place r> ] % + [ >r dup [ data>> ] [ place>> ] bi r> ] % [ swapd bounds-check dispatch ] curry , - [ each pick set-state-place swap set-state-data ] % + [ each pick (>>place) swap (>>date) ] % ] [ ] make [ over make ] curry ; : define-machine ( word state-class -- ) From 6313ca9e33f089423f7991730018c66fe97f591d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:55:29 -0500 Subject: [PATCH 04/17] new accessors --- basis/prettyprint/prettyprint-tests.factor | 6 +++--- basis/prettyprint/sections/sections.factor | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 6ad883cfcb..9bffb34ed1 100755 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -195,11 +195,11 @@ DEFER: parse-error-file : string-layout { - "USING: debugger io kernel lexer ;" + "USING: accessors debugger io kernel ;" "IN: prettyprint.tests" ": string-layout-test ( error -- )" - " \"Expected \" write dup unexpected-want expected>string write" - " \" but got \" write unexpected-got expected>string print ;" + " \"Expected \" write dup want>> expected>string write" + " \" but got \" write got>> expected>string print ;" } ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 168e118d4b..aed476b5c6 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -115,10 +115,10 @@ M: object short-section? section-fits? ; : pprint-section ( section -- ) dup short-section? [ - dup section-style [ short-section ] with-style + dup style>> [ short-section ] with-style ] [ [ > [ long-section ] with-style ] [ long-section> ] tri ] if ; From 17b3a17cecf4293c4692a897f9f35279ee9f1946 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:58:11 -0500 Subject: [PATCH 05/17] new accessors --- basis/concurrency/messaging/messaging-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/concurrency/messaging/messaging-tests.factor b/basis/concurrency/messaging/messaging-tests.factor index b5c022effe..0f9f97c4cc 100755 --- a/basis/concurrency/messaging/messaging-tests.factor +++ b/basis/concurrency/messaging/messaging-tests.factor @@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes concurrency.count-downs accessors ; IN: concurrency.messaging.tests -[ ] [ my-mailbox mailbox-data clear-deque ] unit-test +[ ] [ my-mailbox data>> clear-deque ] unit-test [ "received" ] [ [ From daee5345876415895570582de1f2c0c6c3b35c0e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 30 Aug 2008 21:58:13 -0500 Subject: [PATCH 06/17] Update accessors from ui.gadgets.{grid-lines,grids,incremental,labelled,labels,lists,panes} --- .../gadgets/grid-lines/grid-lines-docs.factor | 2 +- basis/ui/gadgets/grid-lines/grid-lines.factor | 6 +++--- basis/ui/gadgets/grids/grids-docs.factor | 4 ++-- basis/ui/gadgets/grids/grids.factor | 6 +++--- .../ui/gadgets/incremental/incremental.factor | 12 +++++------ basis/ui/gadgets/labelled/labelled.factor | 4 ++-- basis/ui/gadgets/labels/labels.factor | 4 ++-- basis/ui/gadgets/lists/lists.factor | 20 +++++++++---------- basis/ui/gadgets/panes/panes.factor | 8 ++++---- 9 files changed, 33 insertions(+), 33 deletions(-) diff --git a/basis/ui/gadgets/grid-lines/grid-lines-docs.factor b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor index 92f6846774..0838f1ded7 100755 --- a/basis/ui/gadgets/grid-lines/grid-lines-docs.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines-docs.factor @@ -3,4 +3,4 @@ ui.render ; IN: ui.gadgets.grid-lines HELP: grid-lines -{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ; +{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ; diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor index 3f08425e95..f4266adba1 100755 --- a/basis/ui/gadgets/grid-lines/grid-lines.factor +++ b/basis/ui/gadgets/grid-lines/grid-lines.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces opengl opengl.gl sequences +USING: kernel accessors math namespaces opengl opengl.gl sequences math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ; IN: ui.gadgets.grid-lines @@ -10,7 +10,7 @@ C: grid-lines SYMBOL: grid-dim -: half-gap grid get grid-gap [ 2/ ] map ; inline +: half-gap grid get gap>> [ 2/ ] map ; inline : grid-line-from/to ( orientation point -- from to ) half-gap v- @@ -25,7 +25,7 @@ SYMBOL: grid-dim M: grid-lines draw-boundary origin get [ -0.5 -0.5 0.0 glTranslated - grid-lines-color set-color [ + color>> set-color [ dup grid set dup rect-dim half-gap v- grid-dim set compute-grid diff --git a/basis/ui/gadgets/grids/grids-docs.factor b/basis/ui/gadgets/grids/grids-docs.factor index 3217392dd5..64e14c4961 100755 --- a/basis/ui/gadgets/grids/grids-docs.factor +++ b/basis/ui/gadgets/grids/grids-docs.factor @@ -14,9 +14,9 @@ ARTICLE: "ui-grid-layout" "Grid layouts" HELP: grid { $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height." $nl -"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively." +"The " { $snippet "gap" } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively." $nl -"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "." +"The " { $snippet "fill?" } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "." $nl "Grids are created by calling " { $link } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "." $nl diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 4b60b9e5c8..83e5e73662 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -48,7 +48,7 @@ grid dupd add-gaps dim-sum v+ ; M: grid pref-dim* - dup grid-gap swap compute-grid >r over r> + dup gap>> swap compute-grid >r over r> gap-sum >r gap-sum r> (pair-up) ; : do-grid ( dims grid quot -- ) @@ -57,7 +57,7 @@ M: grid pref-dim* drop ; inline : grid-positions ( grid dims -- locs ) - >r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ; + >r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ; : position-grid ( grid horiz vert -- ) pick >r @@ -65,7 +65,7 @@ M: grid pref-dim* pair-up r> [ set-rect-loc ] do-grid ; : resize-grid ( grid horiz vert -- ) - pick grid-fill? [ + pick fill?>> [ pair-up swap [ (>>dim) ] do-grid ] [ 2drop grid>> [ [ prefer ] each ] each diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index 826be68b97..77b88959c9 100755 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/basis/ui/gadgets/incremental/incremental.factor @@ -24,20 +24,20 @@ TUPLE: incremental < pack cursor ; M: incremental pref-dim* dup layout-state>> [ - dup call-next-method over set-incremental-cursor - ] when incremental-cursor ; + dup call-next-method over (>>cursor) + ] when cursor>> ; : next-cursor ( gadget incremental -- cursor ) [ - swap rect-dim swap incremental-cursor + swap rect-dim swap cursor>> 2dup v+ >r vmax r> ] keep orientation>> set-axis ; : update-cursor ( gadget incremental -- ) - [ next-cursor ] keep set-incremental-cursor ; + [ next-cursor ] keep (>>cursor) ; : incremental-loc ( gadget incremental -- ) - dup incremental-cursor swap orientation>> v* + dup cursor>> swap orientation>> v* swap set-rect-loc ; : prefer-incremental ( gadget -- ) @@ -57,5 +57,5 @@ M: incremental pref-dim* not-in-layout dup (clear-gadget) dup forget-pref-dim - { 0 0 } over set-incremental-cursor + { 0 0 } over (>>cursor) parent>> [ relayout ] when* ; diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index 49ccd5aabe..6c7d463b0b 100755 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -16,7 +16,7 @@ TUPLE: labelled-gadget < track content ; swap >>content dup content>> 1 track-add ; -M: labelled-gadget focusable-child* labelled-gadget-content ; +M: labelled-gadget focusable-child* content>> ; : ( gadget title -- gadget ) >r r> ; @@ -53,4 +53,4 @@ TUPLE: closable-gadget < frame content ; swap >>content dup content>> @center grid-add ; -M: closable-gadget focusable-child* closable-gadget-content ; +M: closable-gadget focusable-child* content>> ; diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index 24dbd04fde..af7dff0039 100755 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -14,9 +14,9 @@ TUPLE: label < gadget text font color ; : set-label-string ( string label -- ) CHAR: \n pick memq? [ - >r string-lines r> set-label-text + >r string-lines r> (>>text) ] [ - set-label-text + (>>text) ] if ; inline : label-theme ( gadget -- gadget ) diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor index 795307cf25..67c0ccc496 100755 --- a/basis/ui/gadgets/lists/lists.factor +++ b/basis/ui/gadgets/lists/lists.factor @@ -27,8 +27,8 @@ TUPLE: list < pack index presenter color hook ; control-value length 1- min 0 max ; : bound-index ( list -- ) - dup list-index over calc-bounded-index - swap set-list-index ; + dup index>> over calc-bounded-index + swap (>>index) ; : list-presentation-hook ( list -- quot ) hook>> [ [ list? ] find-parent ] prepend ; @@ -53,18 +53,18 @@ M: list model-changed bound-index ; : selected-rect ( list -- rect ) - dup list-index swap children>> ?nth ; + dup index>> swap children>> ?nth ; M: list draw-gadget* origin get [ - dup list-color set-color + dup color>> set-color selected-rect [ rect-extent gl-fill-rect ] when* ] with-translation ; M: list focusable-child* drop t ; : list-value ( list -- object ) - dup list-index swap control-value ?nth ; + dup index>> swap control-value ?nth ; : scroll>selected ( list -- ) #! We change the rectangle's width to zero to avoid @@ -79,22 +79,22 @@ M: list focusable-child* drop t ; 2drop ] [ [ control-value length rem ] keep - [ set-list-index ] keep + [ (>>index) ] keep [ relayout-1 ] keep scroll>selected ] if ; : select-previous ( list -- ) - dup list-index 1- swap select-index ; + dup index>> 1- swap select-index ; : select-next ( list -- ) - dup list-index 1+ swap select-index ; + dup index>> 1+ swap select-index ; : invoke-value-action ( list -- ) dup list-empty? [ - dup list-hook call + dup hook>> call ] [ - dup list-index swap nth-gadget invoke-secondary + dup index>> swap nth-gadget invoke-secondary ] if ; : select-gadget ( gadget list -- ) diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index dfbeccaad1..b17c66768a 100755 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -173,7 +173,7 @@ M: pane-stream make-span-stream >r pick at r> when* ; inline : apply-foreground-style ( style gadget -- style gadget ) - foreground [ over set-label-color ] apply-style ; + foreground [ over (>>color) ] apply-style ; : apply-background-style ( style gadget -- style gadget ) background [ solid-interior ] apply-style ; @@ -184,7 +184,7 @@ M: pane-stream make-span-stream font-size swap at 12 or 3array ; : apply-font-style ( style gadget -- style gadget ) - over specified-font over set-label-font ; + over specified-font over (>>font) ; : apply-presentation-style ( style gadget -- style gadget ) presented [ ] apply-style ; @@ -255,7 +255,7 @@ M: pane-stream make-block-stream ! Tables : apply-table-gap-style ( style grid -- style grid ) - table-gap [ over set-grid-gap ] apply-style ; + table-gap [ over (>>gap) ] apply-style ; : apply-table-border-style ( style grid -- style grid ) table-border [ over (>>boundary) ] @@ -263,7 +263,7 @@ M: pane-stream make-block-stream : styled-grid ( style grid -- grid ) - f over set-grid-fill? + f over (>>fill?) apply-table-gap-style apply-table-border-style nip ; From 01fee5a1f431accf36ba06a2a077b691d2b40354 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:58:20 -0500 Subject: [PATCH 07/17] new accessors --- basis/multiline/multiline.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index cf671c5609..1cc418a1f6 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces parser lexer kernel sequences words quotations math ; +USING: namespaces parser lexer kernel sequences words quotations math +accessors ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line lexer-line-text ; + lexer get dup next-line text>> ; : (parse-here) ( -- ) next-line-text [ @@ -22,7 +23,7 @@ IN: multiline parse-here 1quotation define-inline ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get lexer-line-text [ + lexer get text>> [ 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 @@ -32,8 +33,8 @@ IN: multiline : parse-multiline-string ( end-text -- str ) [ - lexer get lexer-column swap (parse-multiline-string) - lexer get set-lexer-column + lexer get column>> swap (parse-multiline-string) + lexer get (>>column) ] "" make rest but-last ; : <" From 6d1fbd3e22209144afa3793389f2bade5cf259c5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:58:26 -0500 Subject: [PATCH 08/17] new accessors --- basis/units/units.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/units/units.factor b/basis/units/units.factor index fb93691f0a..7604108b82 100755 --- a/basis/units/units.factor +++ b/basis/units/units.factor @@ -39,7 +39,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; [ dimensions 2array ] bi@ = [ dimensions-not-equal ] unless ; -: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ; +: 2values ( dim dim -- val val ) [ value>> ] bi@ ; : > ] bi@ append ] 2keep + [ [ bot>> ] bi@ append ] 2keep 2values * dimension-op> ; : d-neg ( d -- d ) -1 d* ; From 843eb15522c926c1dfcd8a943da506a067c4f4c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:58:34 -0500 Subject: [PATCH 09/17] new accessors --- extra/classes/tuple/lib/lib.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/classes/tuple/lib/lib.factor b/extra/classes/tuple/lib/lib.factor index 509843b9cd..a234ce0d41 100755 --- a/extra/classes/tuple/lib/lib.factor +++ b/extra/classes/tuple/lib/lib.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel macros sequences slots words classes.tuple -quotations combinators ; +quotations combinators accessors ; IN: classes.tuple.lib : reader-slots ( seq -- quot ) - [ slot-spec-reader 1quotation ] map [ cleave ] curry ; + [ reader>> 1quotation ] map [ cleave ] curry ; MACRO: >tuple< ( class -- ) all-slots rest-slice reader-slots ; From 5c19e28fb99e2352879d803fb4fe057f0112305b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:58:40 -0500 Subject: [PATCH 10/17] new accesors --- extra/inverse/inverse.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 72a74baf68..2340442d5b 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -208,7 +208,7 @@ DEFER: _ : slot-readers ( class -- quot ) all-slots rest ! tail gets rid of delegate - [ slot-spec-reader 1quotation [ keep ] curry ] map concat + [ reader>> 1quotation [ keep ] curry ] map concat [ ] like [ drop ] compose ; : ?wrapped ( object -- wrapped ) From 14eea72acb974749a53e12d308fabb59a5349720 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:58:46 -0500 Subject: [PATCH 11/17] new accessors --- extra/lists/lazy/lazy.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index 6beb6e402d..8a1e73928c 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -24,7 +24,7 @@ TUPLE: lazy-cons car cdr ; : lazy-cons ( car cdr -- promise ) [ promise ] bi@ \ lazy-cons boa T{ promise f f t f } clone - [ set-promise-value ] keep ; + swap >>value ; M: lazy-cons car ( lazy-cons -- car ) car>> force ; From a58dc274db83bbe72e6c82d2a2bf62ccb34171a8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:58:53 -0500 Subject: [PATCH 12/17] new accessors --- extra/morse/morse.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 591915b317..4cce93a5a1 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -116,7 +116,7 @@ LAZY: 'morse-words' ( -- parser ) PRIVATE> : morse> ( str -- str ) - 'morse-words' parse car parse-result-parsed [ + 'morse-words' parse car parsed>> [ [ >string morse>ch ] map >string From ccd5b8ced43994d7a0f8db0b6d2c022562e1bbf5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:59:00 -0500 Subject: [PATCH 13/17] new accessors --- extra/nehe/4/4.factor | 16 ++++++++-------- extra/nehe/5/5.factor | 18 +++++++++--------- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index fc2727159b..429e6d9d9c 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -1,5 +1,5 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui -ui.gadgets ui.render threads ; +ui.gadgets ui.render threads accessors ; IN: nehe.4 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; @@ -10,8 +10,8 @@ TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; : ( -- gadget ) nehe4-gadget new-gadget - 0.0 over set-nehe4-gadget-rtri - 0.0 over set-nehe4-gadget-rquad ; + 0.0 >>rtri + 0.0 >>rquad ; M: nehe4-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; @@ -53,22 +53,22 @@ M: nehe4-gadget draw-gadget* ( gadget -- ) 1.0 -1.0 0.0 glVertex3f -1.0 -1.0 0.0 glVertex3f ] do-state - dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri - dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ; + [ 0.2 + ] change-rtri + [ 0.15 - ] change-rquad drop ; : nehe4-update-thread ( gadget -- ) - dup nehe4-gadget-quit? [ drop ] [ + dup quit?>> [ drop ] [ redraw-interval sleep dup relayout-1 nehe4-update-thread ] if ; M: nehe4-gadget graft* ( gadget -- ) - [ f swap set-nehe4-gadget-quit? ] keep + f >>quit? [ nehe4-update-thread ] in-thread drop ; M: nehe4-gadget ungraft* ( gadget -- ) - t swap set-nehe4-gadget-quit? ; + t >>quit? drop ; : run4 ( -- ) "NeHe Tutorial 4" open-window ; diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index f399a116ed..ebdfcd5367 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -1,5 +1,5 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui -ui.gadgets ui.render threads ; +ui.gadgets ui.render threads accessors ; IN: nehe.5 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; @@ -9,8 +9,8 @@ TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; : ( -- gadget ) nehe5-gadget new-gadget - 0.0 over set-nehe5-gadget-rtri - 0.0 over set-nehe5-gadget-rquad ; + 0.0 >>rtri + 0.0 >>rquad ; M: nehe5-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; @@ -103,11 +103,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- ) 1.0 -1.0 1.0 glVertex3f 1.0 -1.0 -1.0 glVertex3f ] do-state - dup nehe5-gadget-rtri 0.2 + over set-nehe5-gadget-rtri - dup nehe5-gadget-rquad 0.15 - swap set-nehe5-gadget-rquad ; + [ 0.2 + ] change-rtri + [ 0.15 - ] change-rquad drop ; : nehe5-update-thread ( gadget -- ) - dup nehe5-gadget-quit? [ + dup quit?>> [ drop ] [ redraw-interval sleep @@ -116,11 +116,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- ) ] if ; M: nehe5-gadget graft* ( gadget -- ) - [ f swap set-nehe5-gadget-quit? ] keep - [ nehe5-update-thread ] in-thread drop ; + f >>quit? + [ nehe5-update-thread ] in-thread drop ; M: nehe5-gadget ungraft* ( gadget -- ) - t swap set-nehe5-gadget-quit? ; + t >>quit? drop ; : run5 ( -- ) From 3891a7df74f84d64fd0874cc22aa9597f9990a6a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:59:09 -0500 Subject: [PATCH 14/17] new accessors --- extra/ori/ori.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/ori/ori.factor b/extra/ori/ori.factor index 20f022f19f..de720a229f 100644 --- a/extra/ori/ori.factor +++ b/extra/ori/ori.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces +USING: kernel namespaces accessors math math.constants math.functions math.matrices math.vectors sequences splitting grouping self math.trig ; @@ -11,9 +11,9 @@ C: ori ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: ori> ( -- val ) self> ori-val ; +: ori> ( -- val ) self> val>> ; -: >ori ( val -- ) self> set-ori-val ; +: >ori ( val -- ) self> (>>val) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 3eaa63b03acaed509450e85ff97a3a4a0da3a987 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:59:18 -0500 Subject: [PATCH 15/17] new accessors --- extra/pos/pos.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/pos/pos.factor b/extra/pos/pos.factor index 24c5410e99..38eb8dec96 100644 --- a/extra/pos/pos.factor +++ b/extra/pos/pos.factor @@ -1,5 +1,6 @@ -USING: kernel math math.functions math.vectors sequences self ; +USING: kernel math math.functions math.vectors sequences self +accessors ; IN: pos @@ -9,13 +10,13 @@ TUPLE: pos val ; C: pos -: pos> ( -- val ) self> pos-val ; +: pos> ( -- val ) self> val>> ; -: >pos ( val -- ) self> set-pos-val ; +: >pos ( val -- ) self> (>>val) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( pos pos -- n ) pos-val swap pos-val v- [ sq ] map sum sqrt ; +: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ; : move-by ( point -- ) pos> v+ >pos ; From 3d88fec7e5ff33dda350c19b32296a89ed83b636 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:59:30 -0500 Subject: [PATCH 16/17] new accessors --- extra/regexp/regexp.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 1bd81d46ea..4920d481b1 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -270,14 +270,14 @@ TUPLE: regexp source parser ignore-case? ; ] keep regexp boa ; : do-ignore-case ( string regexp -- string regexp ) - dup regexp-ignore-case? [ >r >upper r> ] when ; + dup ignore-case?>> [ >r >upper r> ] when ; : matches? ( string regexp -- ? ) - do-ignore-case regexp-parser just parse nil? not ; + do-ignore-case parser>> just parse nil? not ; : match-head ( string regexp -- end ) - do-ignore-case regexp-parser parse dup nil? - [ drop f ] [ car parse-result-unparsed from>> ] if ; + do-ignore-case parser>> parse dup nil? + [ drop f ] [ car unparsed>> from>> ] if ; ! Literal syntax for regexps : parse-options ( string -- ? ) From 978adcf90c52395d37ffa126795c222fe764cdab Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 Aug 2008 21:59:46 -0500 Subject: [PATCH 17/17] new accessors --- extra/fjsc/fjsc.factor | 4 +-- extra/json/reader/reader.factor | 7 +++-- .../parser-combinators.factor | 28 ++++++++++--------- extra/peg/ebnf/ebnf.factor | 4 +-- 4 files changed, 23 insertions(+), 20 deletions(-) diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 5f1f977d20..e12092603a 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -353,11 +353,11 @@ M: quotation fjsc-parse ( object -- ast ) ] with-string-writer ; : fjsc-compile* ( string -- string ) - 'statement' parse parse-result-ast fjsc-compile ; + 'statement' parse ast>> fjsc-compile ; : fc* ( string -- string ) [ - 'statement' parse parse-result-ast values>> do-expressions + 'statement' parse ast>> values>> do-expressions ] { } make [ write ] each ; diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 6bd6905804..e21b1292e3 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings assocs math math.parser math.vectors math.functions math.order - lists hashtables ascii ; + lists hashtables ascii accessors ; IN: json.reader ! Grammar for JSON from RFC 4627 @@ -169,11 +169,12 @@ LAZY: 'value' ( -- parser ) 'array' , 'number' , ] [<|>] spaced ; +ERROR: could-not-parse-json ; : json> ( string -- object ) #! Parse a json formatted string to a factor object 'value' parse dup nil? [ - "Could not parse json" throw + could-not-parse-json ] [ - car parse-result-parsed + car parsed>> ] if ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 2414c1ced3..a05c140b86 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: lists lists.lazy promises kernel sequences strings math arrays splitting quotations combinators namespaces -unicode.case unicode.categories sequences.deep ; +unicode.case unicode.categories sequences.deep accessors ; IN: parser-combinators ! Parser combinator protocol @@ -13,11 +13,13 @@ M: promise parse ( input parser -- list ) TUPLE: parse-result parsed unparsed ; +ERROR: cannot-parse input ; + : parse-1 ( input parser -- result ) dupd parse dup nil? [ - "Cannot parse " rot append throw + rot cannot-parse ] [ - nip car parse-result-parsed + nip car parsed>> ] if ; C: parse-result @@ -26,12 +28,12 @@ C: parse-result 1list ; : parse-result-parsed-slice ( parse-result -- slice ) - dup parse-result-parsed empty? [ - parse-result-unparsed 0 0 rot + dup parsed>> empty? [ + unparsed>> 0 0 rot ] [ - dup parse-result-unparsed - dup slice-from [ rot parse-result-parsed length - ] keep - rot slice-seq + dup unparsed>> + dup from>> [ rot parsed>> length - ] keep + rot seq>> ] if ; : string= ( str1 str2 ignore-case -- ? ) @@ -132,7 +134,7 @@ TUPLE: and-parser parsers ; : <&> ( parser1 parser2 -- parser ) over and-parser? [ - >r and-parser-parsers r> suffix + >r parsers>> r> suffix ] [ 2array ] if and-parser boa ; @@ -142,11 +144,11 @@ TUPLE: and-parser parsers ; : and-parser-parse ( list p1 -- list ) swap [ - dup parse-result-unparsed rot parse + dup unparsed>> rot parse [ - >r parse-result-parsed r> - [ parse-result-parsed 2array ] keep - parse-result-unparsed + >r parsed>> r> + [ parsed>> 2array ] keep + unparsed>> ] lazy-map-with ] lazy-map-with lconcat ; diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 9ca8f470bb..6e9d78e649 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -508,10 +508,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : check-parse-result ( result -- result ) dup [ - dup parse-result-remaining [ blank? ] trim empty? [ + dup remaining>> [ blank? ] trim empty? [ [ "Unable to fully parse EBNF. Left to parse was: " % - parse-result-remaining % + remaining>> % ] "" make throw ] unless ] [