Merge branch 'master' of git://factorcode.org/git/factor

basis/alarms/alarms.factor

@@ -1,11 +1,15 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators generic init kernel math
+USING: accessors arrays calendar combinators generic init
-namespaces sequences heaps boxes threads debugger quotations
+kernel math namespaces sequences heaps boxes threads debugger
-assocs math.order ;
+quotations assocs math.order ;
 IN: alarms
 
-TUPLE: alarm quot time interval entry ;
+TUPLE: alarm
+    { quot callable initial: [ ] }
+    { time timestamp }
+    interval
+    { entry box } ;
 
 <PRIVATE
 
@@ -15,31 +19,28 @@ SYMBOL: alarm-thread
 : notify-alarm-thread ( -- )
     alarm-thread get-global interrupt ;
 
-: check-alarm
+ERROR: bad-alarm-frequency frequency ;
-    dup duration? over not or [ "Not a duration" throw ] unless
+: check-alarm ( frequency/f -- frequency/f )
-    over timestamp? [ "Not a timestamp" throw ] unless
+    dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
-    pick callable? [ "Not a quotation" throw ] unless ; inline
 
 : <alarm> ( quot time frequency -- alarm )
     check-alarm <box> alarm boa ;
 
 : register-alarm ( alarm -- )
-    dup dup alarm-time alarms get-global heap-push*
+    dup dup time>> alarms get-global heap-push*
-    swap alarm-entry >box
+    swap entry>> >box
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
-    >r alarm-time r> before=? ;
+    [ time>> ] dip before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup alarm-time over alarm-interval time+
+    dup [ swap interval>> time+ ] change-time register-alarm ;
-    over set-alarm-time
-    register-alarm ;
 
 : call-alarm ( alarm -- )
-    dup alarm-entry box> drop
+    [ entry>> box> drop ]
-    dup alarm-quot "Alarm execution" spawn drop
+    [ quot>> "Alarm execution" spawn drop ]
-    dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
+    [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
 
 : (trigger-alarms) ( alarms now -- )
     over heap-empty? [
@@ -57,7 +58,7 @@ SYMBOL: alarm-thread
 
 : next-alarm ( alarms -- timestamp/f )
     dup heap-empty?
-    [ drop f ] [ heap-peek drop alarm-time ] if ;
+    [ drop f ] [ heap-peek drop time>> ] if ;
 
 : alarm-thread-loop ( -- )
     alarms get-global
@@ -66,7 +67,7 @@ SYMBOL: alarm-thread
 
 : cancel-alarms ( alarms -- )
     [
-        heap-pop-all [ nip alarm-entry box> drop ] assoc-each
+        heap-pop-all [ nip entry>> box> drop ] assoc-each
     ] when* ;
 
 : init-alarms ( -- )
@@ -88,4 +89,4 @@ PRIVATE>
     [ hence ] keep add-alarm ;
 
 : cancel-alarm ( alarm -- )
-    alarm-entry [ alarms get-global heap-delete ] if-box? ;
+    entry>> [ alarms get-global heap-delete ] if-box? ;

basis/alias/alias-docs.factor

@@ -0,0 +1,15 @@
+USING: kernel words help.markup help.syntax ;
+IN: alias
+
+HELP: ALIAS:
+{ $syntax "ALIAS: new-word existing-word" }
+{ $values { "new-word" word } { "existing-word" word } }
+{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
+{ $examples
+    { $example "ALIAS: sequence-nth nth"
+               "0 { 10 20 30 } sequence-nth"
+               "10"
+    }
+} ;
+
+

basis/ascii/ascii.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.order sequences ;
+USING: kernel math math.order sequences
+combinators.short-circuit ;
 IN: ascii
 
 : blank? ( ch -- ? ) " \t\n\r" member? ; inline
@@ -20,7 +21,7 @@ IN: ascii
     dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
 
 : Letter? ( ch -- ? )
-    dup letter? [ drop t ] [ LETTER? ] if ; inline
+    [ [ letter? ] [ LETTER? ] ] 1|| ;
 
 : alpha? ( ch -- ? )
-    dup Letter? [ drop t ] [ digit? ] if ; inline
+    [ [ Letter? ] [ digit? ] ] 1|| ;

basis/base64/base64-tests.factor

@@ -1,4 +1,5 @@
 USING: kernel tools.test base64 strings ;
+IN: base64.tests
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
 ] unit-test

basis/base64/base64.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences io.binary splitting grouping ;
 IN: base64
 

basis/biassocs/biassocs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs accessors ;
+USING: kernel assocs accessors summary ;
 IN: biassocs
 
 TUPLE: biassoc from to ;
@@ -23,8 +23,13 @@ M: biassoc value-at* to>> at* ;
 M: biassoc set-at
     [ from>> set-at ] [ swapd to>> once-at ] 3bi ;
 
+ERROR: no-biassoc-deletion ;
+
+M: no-biassoc-deletion summary
+    drop "biassocs do not support deletion" ;
+
 M: biassoc delete-at
-    "biassocs do not support deletion" throw ;
+    no-biassoc-deletion ;
 
 M: biassoc >alist
     from>> >alist ;

basis/bootstrap/handbook/handbook.factor

@@ -1,3 +1,4 @@
 USING: vocabs.loader vocabs kernel ;
+IN: bootstrap.handbook
 
 "bootstrap.help" vocab [ "help.handbook" require ] when

basis/bootstrap/random/random.factor

@@ -1,6 +1,7 @@
 USING: vocabs.loader sequences system
 random random.mersenne-twister combinators init
 namespaces random ;
+IN: bootstrap.random
 
 "random.mersenne-twister" require
 

basis/bootstrap/tools/tools.factor

@@ -1,4 +1,5 @@
 USING: vocabs.loader sequences ;
+IN: bootstrap.tools
 
 {
     "inspector"

basis/bootstrap/ui/ui.factor

@@ -1,5 +1,6 @@
 USING: alien namespaces system combinators kernel sequences
 vocabs vocabs.loader ;
+IN: bootstrap.ui
 
 "bootstrap.compiler" vocab [
     "ui-backend" get [

basis/bootstrap/unicode/unicode.factor

@@ -1,4 +1,5 @@
 USING: strings.parser kernel namespaces unicode.data ;
+IN: bootstrap.unicode
 
 [ name>char [ "Invalid character" throw ] unless* ]
 name>char-hook set-global

basis/calendar/calendar-docs.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math strings help.markup help.syntax
+calendar.backend ;
+IN: calendar
+
+HELP: duration
+{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds.  All duration slots can store " { $link real } " numbers." } ;
+
+HELP: timestamp
+{ $description "A timestamp is a date and a time with a timezone offset.  Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } "." } ;
+
+{ timestamp duration } related-words
+
+HELP: gmt-offset-duration
+{ $values { "duration" duration } }
+{ $description "Returns a " { $link duration } " object with the GMT offset returned by " { $link gmt-offset } "." } ;
+
+HELP: <date>
+{ $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } }
+{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "12 25 2010 <date> ."
+                "T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }"
+    }
+} ;
+
+HELP: month-names
+{ $values { "array" array } }
+{ $description "Returns an array with the English names of all the months. January has a index of 1 instead of 0." } ;

basis/calendar/calendar.factor

@@ -1,52 +1,90 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: arrays kernel math math.functions namespaces sequences
 strings system vocabs.loader calendar.backend threads
 accessors combinators locals classes.tuple math.order
-memoize ;
+memoize summary combinators.short-circuit ;
 IN: calendar
 
-TUPLE: timestamp year month day hour minute second gmt-offset ;
+TUPLE: duration
-
+    { year real }
-C: <timestamp> timestamp
+    { month real }
-
+    { day real }
-TUPLE: duration year month day hour minute second ;
+    { hour real }
+    { minute real }
+    { second real } ;
 
 C: <duration> duration
 
+TUPLE: timestamp
+    { year integer }
+    { month integer }
+    { day integer }
+    { hour integer }
+    { minute integer }
+    { second real }
+    { gmt-offset duration } ;
+
+C: <timestamp> timestamp
+
 : gmt-offset-duration ( -- duration )
     0 0 0 gmt-offset <duration> ;
 
 : <date> ( year month day -- timestamp )
     0 0 0 gmt-offset-duration <timestamp> ;
 
-: month-names
+ERROR: not-a-month n ;
+M: not-a-month summary
+    drop "Months are indexed starting at 1" ;
+
+<PRIVATE
+: check-month ( n -- n )
+    dup zero? [ not-a-month ] when ;
+PRIVATE>
+
+: month-names ( -- array )
     {
-        "Not a month" "January" "February" "March" "April" "May" "June"
+        "January" "February" "March" "April" "May" "June"
         "July" "August" "September" "October" "November" "December"
     } ;
 
-: month-abbreviations
+: month-name ( n -- string )
+    check-month 1- month-names nth ;
+
+: month-abbreviations ( -- array )
     {
-        "Not a month"
+        "Jan" "Feb" "Mar" "Apr" "May" "Jun"
-        "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
+        "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
     } ;
 
-: day-names
+: month-abbreviation ( n -- array )
+    check-month 1- month-abbreviations nth ;
+
+: day-names ( -- array )
     {
         "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
     } ;
 
-: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
+: day-name ( n -- string ) day-names nth ;
-: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
 
-: average-month 30+5/12 ; inline
+: day-abbreviations2 ( -- array )
-: months-per-year 12 ; inline
+    { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
-: days-per-year 3652425/10000 ; inline
+
-: hours-per-year 876582/100 ; inline
+: day-abbreviation2 ( n -- string )
-: minutes-per-year 5259492/10 ; inline
+    day-abbreviations2 nth ;
-: seconds-per-year 31556952 ; inline
+
+: day-abbreviations3 ( -- array )
+    { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
+
+: day-abbreviation3 ( n -- string )
+    day-abbreviations3 nth ;
+
+: average-month ( -- ratio ) 30+5/12 ; inline
+: months-per-year ( -- integer ) 12 ; inline
+: days-per-year ( -- ratio ) 3652425/10000 ; inline
+: hours-per-year ( -- ratio ) 876582/100 ; inline
+: minutes-per-year ( -- ratio ) 5259492/10 ; inline
+: seconds-per-year ( -- integer ) 31556952 ; inline
 
 :: julian-day-number ( year month day -- n )
     #! Returns a composite date number
@@ -113,10 +151,12 @@ GENERIC: +second ( timestamp x -- timestamp )
     [ floor >integer ] keep over - ;
 
 : adjust-leap-year ( timestamp -- timestamp )
-    dup day>> 29 = over month>> 2 = pick leap-year? not and and
+    dup
+    { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
     [ 3 >>month 1 >>day ] when ;
 
-: unless-zero >r dup zero? [ drop ] r> if ; inline
+: unless-zero ( n quot -- )
+    [ dup zero? [ drop ] ] dip if ; inline
 
 M: integer +year ( timestamp n -- timestamp )
     [ [ + ] curry change-year adjust-leap-year ] unless-zero ;

basis/calendar/format/format.factor

@@ -26,11 +26,11 @@ IN: calendar.format
 
 : DD ( time -- ) day>> write-00 ;
 
-: DAY ( time -- ) day-of-week day-abbreviations3 nth write ;
+: DAY ( time -- ) day-of-week day-abbreviation3 write ;
 
 : MM ( time -- ) month>> write-00 ;
 
-: MONTH ( time -- ) month>> month-abbreviations nth write ;
+: MONTH ( time -- ) month>> month-abbreviation write ;
 
 : YYYY ( time -- ) year>> write-0000 ;
 
@@ -57,7 +57,7 @@ GENERIC: month. ( obj -- )
 
 M: array month. ( pair -- )
     first2
-    [ month-names nth write bl number>string print ]
+    [ month-name write bl number>string print ]
     [ 1 zeller-congruence ]
     [ (days-in-month) day-abbreviations2 " " join print ] 2tri
     over "   " <repetition> concat write
@@ -191,7 +191,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token day-abbreviations3 member? check-timestamp drop
         read1 CHAR: \s assert=
         read-sp checked-number >>day
-        read-sp month-abbreviations index check-timestamp >>month
+        read-sp month-abbreviations index 1+ check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -206,7 +206,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token day-abbreviations3 member? check-timestamp drop
         read1 CHAR: \s assert=
         "-" read-token checked-number >>day
-        "-" read-token month-abbreviations index check-timestamp >>month
+        "-" read-token month-abbreviations index 1+ check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -219,7 +219,7 @@ ERROR: invalid-timestamp-format ;
 : (cookie-string>timestamp-2) ( -- timestamp )
     timestamp new
         read-sp day-abbreviations3 member? check-timestamp drop
-        read-sp month-abbreviations index check-timestamp >>month
+        read-sp month-abbreviations index 1+ check-timestamp >>month
         read-sp checked-number >>day
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute

basis/cocoa/messages/messages.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings
+USING: accessors alien alien.c-types alien.strings
 arrays assocs combinators compiler kernel
 math namespaces parser prettyprint prettyprint.sections
 quotations sequences strings words cocoa.runtime io macros
@@ -46,11 +46,11 @@ TUPLE: selector name object ;
 MEMO: <selector> ( name -- sel ) f \ selector boa ;
 
 : selector ( selector -- alien )
-    dup selector-object expired? [
+    dup object>> expired? [
-        dup selector-name sel_registerName
+        dup name>> sel_registerName
-        dup rot set-selector-object
+        [ >>object drop ] keep
     ] [
-        selector-object
+        object>>
     ] if ;
 
 SYMBOL: objc-methods

basis/compiler/generator/fixup/fixup.factor

@@ -15,7 +15,7 @@ TUPLE: frame-required n ;
 
 : stack-frame-size ( code -- n )
     no-stack-frame [
-        dup frame-required? [ frame-required-n max ] [ drop ] if
+        dup frame-required? [ n>> max ] [ drop ] if
     ] reduce ;
 
 GENERIC: fixup* ( frame-size obj -- frame-size )
@@ -29,7 +29,7 @@ TUPLE: label offset ;
 : <label> ( -- label ) label new ;
 
 M: label fixup*
-    compiled-offset swap set-label-offset ;
+    compiled-offset >>offset drop ;
 
 : define-label ( name -- ) <label> swap set ;
 
@@ -138,7 +138,7 @@ SYMBOL: literal-table
 
 : resolve-labels ( labels -- labels' )
     [
-        first3 label-offset
+        first3 offset>>
         [ "Unresolved label" throw ] unless*
         3array
     ] map concat ;

basis/compiler/generator/registers/registers.factor

@@ -102,12 +102,12 @@ TUPLE: cached loc vreg ;
 
 C: <cached> cached
 
-M: cached set-operand-class cached-vreg set-operand-class ;
+M: cached set-operand-class vreg>> set-operand-class ;
-M: cached operand-class* cached-vreg operand-class* ;
+M: cached operand-class* vreg>> operand-class* ;
 M: cached move-spec drop cached ;
-M: cached live-vregs* cached-vreg live-vregs* ;
+M: cached live-vregs* vreg>> live-vregs* ;
 M: cached live-loc? cached-loc live-loc? ;
-M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
+M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
 M: cached lazy-store
     2dup cached-loc live-loc?
     [ "live-locs" get at %move ] [ 2drop ] if ;
@@ -169,7 +169,7 @@ INSTANCE: unboxed-c-ptr value
 ! A constant value
 TUPLE: constant value ;
 C: <constant> constant
-M: constant operand-class* constant-value class ;
+M: constant operand-class* value>> class ;
 M: constant move-spec class ;
 
 INSTANCE: constant value
@@ -204,7 +204,7 @@ INSTANCE: constant value
         { { f unboxed-c-ptr } [ %move-bug ] }
         { { f unboxed-byte-array } [ %move-bug ] }
 
-        { { f constant } [ constant-value swap load-literal ] }
+        { { f constant } [ value>> swap load-literal ] }
 
         { { f float } [ %box-float ] }
         { { f unboxed-alien } [ %box-alien ] }
@@ -420,7 +420,7 @@ M: loc lazy-store
     #! with the area of the data stack above the stack pointer
     find-tmp-loc slow-shuffle-mapping [
         [
-            swap dup cached? [ cached-vreg ] when %move
+            swap dup cached? [ vreg>> ] when %move
         ] assoc-each
     ] keep >hashtable do-shuffle ;
 
@@ -480,7 +480,7 @@ M: loc lazy-store
 : substitute-vreg? ( old new -- ? )
     #! We don't substitute locs for float or alien vregs,
     #! since in those cases the boxing overhead might kill us.
-    cached-vreg tagged? >r loc? r> and ;
+    vreg>> tagged? >r loc? r> and ;
 
 : substitute-vregs ( values vregs -- )
     [ vreg-substitution ] 2map
@@ -488,7 +488,7 @@ M: loc lazy-store
     [ >r stack>> r> substitute-here ] curry each-phantom ;
 
 : set-operand ( value var -- )
-    >r dup constant? [ constant-value ] when r> set ;
+    >r dup constant? [ value>> ] when r> set ;
 
 : lazy-load ( values template -- )
     #! Set operand vars here.
@@ -506,7 +506,7 @@ M: loc lazy-store
 
 : clash? ( seq -- ? )
     phantoms [ stack>> ] bi@ append [
-        dup cached? [ cached-vreg ] when swap member?
+        dup cached? [ vreg>> ] when swap member?
     ] with contains? ;
 
 : outputs-clash? ( -- ? )
@@ -516,7 +516,7 @@ M: loc lazy-store
 
 : count-input-vregs ( phantom spec -- )
     phantom&spec [
-        >r dup cached? [ cached-vreg ] when r> first allocation
+        >r dup cached? [ vreg>> ] when r> first allocation
     ] 2map count-vregs ;
 
 : count-scratch-regs ( spec -- )
@@ -557,7 +557,7 @@ M: loc lazy-store
     #! the value is always good.
     dup quotation? [
         over constant?
-        [ >r constant-value r> call ] [ 2drop f ] if
+        [ >r value>> r> call ] [ 2drop f ] if
     ] [
         2drop t
     ] if ;
@@ -648,7 +648,7 @@ UNION: immediate fixnum POSTPONE: f ;
     phantom-datastack get stack>> push ;
 
 : phantom-shuffle ( shuffle -- )
-    [ effect-in length phantom-datastack get phantom-input ] keep
+    [ in>> length phantom-datastack get phantom-input ] keep
     shuffle* phantom-datastack get phantom-append ;
 
 : phantom->r ( n -- )

basis/compiler/tests/alien.factor

@@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
 namespaces namespaces tools.test sequences stack-checker
 stack-checker.errors words arrays parser quotations
 continuations effects namespaces.private io io.streams.string
-memory system threads tools.test math ;
+memory system threads tools.test math accessors ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test
@@ -288,7 +288,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 
 : callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
 
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
 
 [ t ] [ callback-1 alien? ] unit-test
 

basis/compiler/tests/redefine5.factor

@@ -0,0 +1,32 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Regression: if dispatch was eliminated but method was not inlined,
+! compiled usage information was not recorded.
+
+[ "compiler.tests.redefine5" forget-vocab ] with-compilation-unit
+
+[ ] [
+    <"
+    USING: sorting kernel math.order ;
+    IN: compiler.tests.redefine5
+    GENERIC: my-generic ( a -- b )
+    M: object my-generic [ <=> ] sort ;
+    : my-inline ( a -- b ) my-generic ;
+    "> eval
+] unit-test
+
+[ ] [
+    <"
+    USE: kernel
+    IN: compiler.tests.redefine5
+    TUPLE: my-tuple ;
+    M: my-tuple my-generic drop 0 ;
+    "> eval
+] unit-test
+
+[ 0 ] [
+    "my-tuple" "compiler.tests.redefine5" lookup boa
+    "my-inline" "compiler.tests.redefine5" lookup execute
+] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -51,9 +51,11 @@ GENERIC: cleanup* ( node -- node/nodes )
     tri prefix ;
 
 : cleanup-inlining ( #call -- nodes )
-    [ dup method>> [ drop ] [ word>> +inlined+ depends-on ] if ]
+    [
-    [ body>> cleanup ]
+        dup method>>
-    bi ;
+        [ method>> dup word? [ +called+ depends-on ] [ drop ] if ]
+        [ word>> +inlined+ depends-on ] if
+    ] [ body>> cleanup ] bi ;
 
 ! Removing overflow checks
 : no-overflow-variant ( op -- fast-op )

basis/concurrency/futures/futures.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises concurrency.mailboxes kernel arrays
-continuations ;
+continuations accessors ;
 IN: concurrency.futures
 
 : future ( quot -- future )
     <promise> [
         [ [ >r call r> fulfill ] 2curry "Future" ] keep
-        promise-mailbox spawn-linked-to drop
+        mailbox>> spawn-linked-to drop
     ] keep ; inline
 
 : ?future-timeout ( future timeout -- value )

basis/concurrency/messaging/messaging.factor

@@ -4,7 +4,7 @@
 ! Concurrency library for Factor, based on Erlang/Termite style
 ! concurrency.
 USING: kernel threads concurrency.mailboxes continuations
-namespaces assocs random ;
+namespaces assocs random accessors ;
 IN: concurrency.messaging
 
 GENERIC: send ( message thread -- )
@@ -45,11 +45,11 @@ TUPLE: synchronous data sender tag ;
 TUPLE: reply data tag ;
 
 : <reply> ( data synchronous -- reply )
-    synchronous-tag \ reply boa ;
+    tag>> \ reply boa ;
 
 : synchronous-reply? ( response synchronous -- ? )
     over reply?
-    [ >r reply-tag r> synchronous-tag = ]
+    [ >r tag>> r> tag>> = ]
     [ 2drop f ] if ;
 
 : send-synchronous ( message thread -- reply )
@@ -58,15 +58,15 @@ TUPLE: reply data tag ;
     ] [
         >r <synchronous> dup r> send
         [ synchronous-reply? ] curry receive-if
-        reply-data
+        data>>
     ] if ;
 
 : reply-synchronous ( message synchronous -- )
-    [ <reply> ] keep synchronous-sender send ;
+    [ <reply> ] keep sender>> send ;
 
 : handle-synchronous ( quot -- )
     receive [
-        synchronous-data swap call
+        data>> swap call
     ] keep reply-synchronous ; inline
 
 <PRIVATE

basis/concurrency/promises/promises.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.mailboxes kernel continuations ;
+USING: accessors concurrency.mailboxes kernel continuations ;
 IN: concurrency.promises
 
 TUPLE: promise mailbox ;
@@ -9,17 +9,17 @@ TUPLE: promise mailbox ;
     <mailbox> promise boa ;
 
 : promise-fulfilled? ( promise -- ? )
-    promise-mailbox mailbox-empty? not ;
+    mailbox>> mailbox-empty? not ;
 
 : fulfill ( value promise -- )
     dup promise-fulfilled? [ 
         "Promise already fulfilled" throw
     ] [
-        promise-mailbox mailbox-put
+        mailbox>> mailbox-put
     ] if ;
 
 : ?promise-timeout ( promise timeout -- result )
-    >r promise-mailbox r> block-if-empty mailbox-peek ;
+    >r mailbox>> r> block-if-empty mailbox-peek ;
 
 : ?promise ( promise -- result )
     f ?promise-timeout ;

basis/concurrency/semaphores/semaphores.factor

@@ -1,29 +1,34 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel threads math concurrency.conditions
-continuations ;
+continuations accessors summary ;
 IN: concurrency.semaphores
 
 TUPLE: semaphore count threads ;
 
+ERROR: negative-count-semaphore ;
+
+M: negative-count-semaphore summary
+    drop "Cannot have semaphore with negative count" ;
+
 : <semaphore> ( n -- semaphore )
-    dup 0 < [ "Cannot have semaphore with negative count" throw ] when
+    dup 0 < [ negative-count-semaphore ] when
     <dlist> semaphore boa ;
 
 : wait-to-acquire ( semaphore timeout -- )
-    >r semaphore-threads r> "semaphore" wait ;
+    [ threads>> ] dip "semaphore" wait ;
 
 : acquire-timeout ( semaphore timeout -- )
-    over semaphore-count zero?
+    over count>> zero?
     [ dupd wait-to-acquire ] [ drop ] if
-    dup semaphore-count 1- swap set-semaphore-count ;
+    [ 1- ] change-count drop ;
 
 : acquire ( semaphore -- )
     f acquire-timeout ;
 
 : release ( semaphore -- )
-    dup semaphore-count 1+ over set-semaphore-count
+    [ 1+ ] change-count
-    semaphore-threads notify-1 ;
+    threads>> notify-1 ;
 
 : with-semaphore-timeout ( semaphore timeout quot -- )
     pick rot acquire-timeout swap

basis/debugger/debugger.factor

@@ -23,16 +23,16 @@ M: tuple error-help class ;
 M: string error. print ;
 
 : :s ( -- )
-    error-continuation get continuation-data stack. ;
+    error-continuation get data>> stack. ;
 
 : :r ( -- )
-    error-continuation get continuation-retain stack. ;
+    error-continuation get retain>> stack. ;
 
 : :c ( -- )
-    error-continuation get continuation-call callstack. ;
+    error-continuation get call>> callstack. ;
 
 : :get ( variable -- value )
-    error-continuation get continuation-name assoc-stack ;
+    error-continuation get name>> assoc-stack ;
 
 : :res ( n -- * )
     1- restarts get-global nth f restarts set-global restart ;
@@ -44,7 +44,7 @@ M: string error. print ;
 : restart. ( restart n -- )
     [
         1+ dup 3 <= [ ":" % # "    " % ] [ # " :res  " % ] if
-        restart-name %
+        name>> %
     ] "" make print ;
 
 : restarts. ( -- )

basis/documents/documents.factor

@@ -26,7 +26,7 @@ TUPLE: document < model locs ;
 : remove-loc ( loc document -- ) locs>> delete ;
 
 : update-locs ( loc document -- )
-    document-locs [ set-model ] with each ;
+    locs>> [ set-model ] with each ;
 
 : doc-line ( n document -- string ) model-value nth ;
 
@@ -132,7 +132,7 @@ TUPLE: document < model locs ;
 
 : set-doc-string ( string document -- )
     >r string-lines V{ } like r> [ set-model ] keep
-    dup doc-end swap update-locs ;
+    [ doc-end ] [ update-locs ] bi ;
 
 : clear-doc ( document -- )
     "" swap set-doc-string ;

basis/heaps/heaps-tests.factor

@@ -48,7 +48,7 @@ IN: heaps.tests
 : test-entry-indices ( n -- ? )
     random-alist
     <min-heap> [ heap-push-all ] keep
-    data>> dup length swap [ entry-index ] map sequence= ;
+    data>> dup length swap [ index>> ] map sequence= ;
 
 14 [
     [ t ] swap [ 2^ test-entry-indices ] curry unit-test
@@ -58,7 +58,7 @@ IN: heaps.tests
     dup length random dup pick nth >r swap delete-nth r> ;
 
 : sort-entries ( entries -- entries' )
-    [ [ entry-key ] compare ] sort ;
+    [ [ key>> ] compare ] sort ;
 
 : delete-test ( n -- ? )
     [
@@ -67,7 +67,7 @@ IN: heaps.tests
         dup data>> clone swap
     ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
     data>>
-    [ [ entry-key ] map ] bi@
+    [ [ key>> ] map ] bi@
     [ natural-sort ] bi@ ;
 
 11 [

basis/heaps/heaps.factor

@@ -2,7 +2,7 @@
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences arrays assocs sequences.private
-growable accessors math.order ;
+growable accessors math.order summary ;
 IN: heaps
 
 GENERIC: heap-push* ( value key heap -- entry )
@@ -61,7 +61,7 @@ M: heap heap-size ( heap -- n )
     >r right r> data-nth ; inline
 
 : data-set-nth ( entry n heap -- )
-    >r [ swap set-entry-index ] 2keep r>
+    >r [ >>index drop ] 2keep r>
     data>> set-nth-unsafe ;
 
 : data-push ( entry heap -- n )
@@ -87,7 +87,7 @@ M: heap heap-size ( heap -- n )
 
 GENERIC: heap-compare ( pair1 pair2 heap -- ? )
 
-: (heap-compare) drop [ entry-key ] compare ; inline
+: (heap-compare) drop [ key>> ] compare ; inline
 
 M: min-heap heap-compare (heap-compare) +gt+ eq? ;
 
@@ -161,11 +161,14 @@ M: heap heap-push* ( value key heap -- entry )
 M: heap heap-peek ( heap -- value key )
     data-first >entry< ;
 
+ERROR: bad-heap-delete ;
+
+M: bad-heap-delete summary 
+    drop "Invalid entry passed to heap-delete" ;
+    
 : entry>index ( entry heap -- n )
-    over entry-heap eq? [
+    over heap>> eq? [ bad-heap-delete ] unless
-        "Invalid entry passed to heap-delete" throw
+    index>> ;
-    ] unless
-    entry-index ;
 
 M: heap heap-delete ( entry heap -- )
     [ entry>index ] keep

basis/help/topics/topics.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.x
-USING: arrays definitions generic assocs
+USING: accessors arrays definitions generic assocs
 io kernel namespaces prettyprint prettyprint.sections
 sequences words summary classes strings vocabs ;
 IN: help.topics
@@ -16,12 +16,12 @@ M: link >link ;
 M: vocab-spec >link ;
 M: object >link link boa ;
 
-PREDICATE: word-link < link link-name word? ;
+PREDICATE: word-link < link name>> word? ;
 
 M: link summary
     [
         "Link: " %
-        link-name dup word? [ summary ] [ unparse ] if %
+        name>> dup word? [ summary ] [ unparse ] if %
     ] "" make ;
 
 ! Help articles
@@ -44,9 +44,7 @@ TUPLE: article title content loc ;
 
 M: article article-name article-title ;
 
-TUPLE: no-article name ;
+ERROR: no-article name ;
-
-: no-article ( name -- * ) \ no-article boa throw ;
 
 M: no-article summary
     drop "Help article does not exist" ;
@@ -60,11 +58,11 @@ M: object article-content article article-content ;
 M: object article-parent article-xref get at ;
 M: object set-article-parent article-xref get set-at ;
 
-M: link article-name link-name article-name ;
+M: link article-name name>> article-name ;
-M: link article-title link-name article-title ;
+M: link article-title name>> article-title ;
-M: link article-content link-name article-content ;
+M: link article-content name>> article-content ;
-M: link article-parent link-name article-parent ;
+M: link article-parent name>> article-parent ;
-M: link set-article-parent link-name set-article-parent ;
+M: link set-article-parent name>> set-article-parent ;
 
 ! Special case: f help
 M: f article-name drop \ f article-name ;

basis/inspector/inspector.factor

@@ -72,7 +72,7 @@ M: tuple error. describe ;
     namestack namestack. ;
 
 : :vars ( -- )
-    error-continuation get continuation-name namestack. ;
+    error-continuation get name>> namestack. ;
 
 SYMBOL: inspector-hook
 

basis/io/buffers/buffers-docs.factor

@@ -35,8 +35,8 @@ HELP: buffer
 $nl
 "Buffers have two internal pointers:"
 { $list
-    { { $link buffer-fill } " - the fill pointer, a write index where new data is added" }
+    { { $snippet "fill" } " - the fill pointer, a write index where new data is added" }
-    { { $link buffer-pos } " - the position, a read index where data is consumed" }
+    { { $snippet "pos" } " - the position, a read index where data is consumed" }
 } } ;
 
 HELP: <buffer>

basis/io/launcher/launcher.factor

@@ -53,7 +53,7 @@ SYMBOL: +realtime-priority+
     dup handle>> swap status>> or ;
 
 : process-running? ( process -- ? )
-    process-handle >boolean ;
+    handle>> >boolean ;
 
 ! Non-blocking process exit notification facility
 SYMBOL: processes
@@ -80,7 +80,7 @@ SYMBOL: wait-flag
     V{ } clone swap processes get set-at
     wait-flag get-global raise-flag ;
 
-M: process hashcode* process-handle hashcode* ;
+M: process hashcode* handle>> hashcode* ;
 
 : pass-environment? ( process -- ? )
     dup environment>> assoc-empty? not
@@ -99,9 +99,14 @@ M: process hashcode* process-handle hashcode* ;
 
 GENERIC: >process ( obj -- process )
 
+ERROR: process-already-started ;
+
+M: process-already-started summary
+    drop "Process has already been started once" ;
+
 M: process >process
     dup process-started? [
-        "Process has already been started once" throw
+        process-already-started
     ] when
     clone ;
 
@@ -111,6 +116,8 @@ HOOK: current-process-handle io-backend ( -- handle )
 
 HOOK: run-process* io-backend ( process -- handle )
 
+ERROR: process-was-killed ;
+
 : wait-for-process ( process -- status )
     [
         dup handle>>
@@ -119,7 +126,7 @@ HOOK: run-process* io-backend ( process -- handle )
             "process" suspend drop
         ] when
         dup killed>>
-        [ "Process was killed" throw ] [ status>> ] if
+        [ process-was-killed ] [ status>> ] if
     ] with-timeout ;
 
 : run-detached ( desc -- process )
@@ -150,7 +157,7 @@ HOOK: kill-process* io-backend ( handle -- )
 
 M: process timeout timeout>> ;
 
-M: process set-timeout set-process-timeout ;
+M: process set-timeout swap >>timeout drop ;
 
 M: process cancel-operation kill-process ;
 
@@ -222,10 +229,12 @@ GENERIC: underlying-handle ( stream -- handle )
 
 M: port underlying-handle handle>> ;
 
+ERROR: invalid-duplex-stream ;
+
 M: duplex-stream underlying-handle
     [ in>> underlying-handle ]
     [ out>> underlying-handle ] bi
-    [ = [ "Invalid duplex stream" throw ] when ] keep ;
+    [ = [ invalid-duplex-stream ] when ] keep ;
 
 M: encoder underlying-handle
     stream>> underlying-handle ;

basis/io/styles/styles.factor

@@ -1,8 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: hashtables io colors ;
-
 IN: io.styles
 
 SYMBOL: plain

basis/locals/locals.factor

@@ -75,7 +75,7 @@ TUPLE: quote local ;
 C: <quote> quote
 
 : local-index ( obj args -- n )
-    [ dup quote? [ quote-local ] when eq? ] with find drop ;
+    [ dup quote? [ local>> ] when eq? ] with find drop ;
 
 : read-local-quot ( obj args -- quot )
     local-index 1+ [ get-local ] curry ;
@@ -87,7 +87,7 @@ C: <quote> quote
 : localize ( obj args -- quot )
     {
         { [ over local? ]        [ read-local-quot ] }
-        { [ over quote? ]        [ >r quote-local r> read-local-quot ] }
+        { [ over quote? ]        [ >r local>> r> read-local-quot ] }
         { [ over local-word? ]   [ read-local-quot [ call ] append ] }
         { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
         { [ over local-writer? ] [ localize-writer ] }
@@ -418,7 +418,7 @@ M: lambda-memoized reset-word
 : method-stack-effect ( method -- effect )
     dup "lambda" word-prop vars>>
     swap "method-generic" word-prop stack-effect
-    dup [ effect-out ] when
+    dup [ out>> ] when
     <effect> ;
 
 M: lambda-method synopsis*

basis/macros/macros.factor

@@ -2,14 +2,14 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel sequences words effects
 stack-checker.transforms combinators assocs definitions
-quotations namespaces memoize ;
+quotations namespaces memoize accessors ;
 IN: macros
 
 : real-macro-effect ( word -- effect' )
-    "declared-effect" word-prop effect-in 1 <effect> ;
+    "declared-effect" word-prop in>> 1 <effect> ;
 
 : define-macro ( word definition -- )
-    over "declared-effect" word-prop effect-in length >r
+    over "declared-effect" word-prop in>> length >r
     2dup "macro" set-word-prop
     2dup over real-macro-effect memoize-quot [ call ] append define
     r> define-transform ;

basis/math/intervals/intervals-docs.factor

@@ -88,7 +88,7 @@ ABOUT: "math-intervals"
 HELP: interval
 { $class-description "An interval represents a set of real numbers between two endpoints; the endpoints can either be included or excluded from the interval."
 $nl
-"The " { $link interval-from } " and " { $link interval-to } " slots store endpoints, represented as arrays of the shape " { $snippet "{ number included? }" } "."
+"The " { $snippet "from" } " and " { $snippet "to" } " slots store endpoints, represented as arrays of the shape " { $snippet "{ number included? }" } "."
 $nl
 "Intervals are created by calling " { $link [a,b] } ", " { $link (a,b) } ", " { $link [a,b) } ", " { $link (a,b] } " or " { $link [a,a] } "." } ;
 

basis/memoize/memoize.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel hashtables sequences arrays words namespaces
-parser math assocs effects definitions quotations ;
+parser math assocs effects definitions quotations summary
+accessors ;
 IN: memoize
 
 : packer ( n -- quot )
@@ -11,10 +12,10 @@ IN: memoize
     { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
 
 : #in ( word -- n )
-    stack-effect effect-in length ;
+    stack-effect in>> length ;
 
 : #out ( word -- n )
-    stack-effect effect-out length ;
+    stack-effect out>> length ;
 
 : pack/unpack ( quot word -- newquot )
     [ dup #in unpacker % swap % #out packer % ] [ ] make ;
@@ -28,10 +29,13 @@ IN: memoize
         #out unpacker %
     ] [ ] make ;
 
+ERROR: too-many-arguments ;
+
+M: too-many-arguments summary
+    drop "There must be no more than 4 input and 4 output arguments" ;
+
 : check-memoized ( word -- )
-    dup #in 4 > swap #out 4 > or [
+    dup #in 4 > swap #out 4 > or [ too-many-arguments ] when ;
-        "There must be no more than 4 input and 4 output arguments" throw
-    ] when ;
 
 : define-memoized ( word quot -- )
     over check-memoized

basis/mirrors/mirrors.factor

@@ -16,10 +16,13 @@ M: mirror at*
     [ nip object>> ] [ object-slots slot-named ] 2bi
     dup [ offset>> slot t ] [ 2drop f f ] if ;
 
+ERROR: no-such-slot slot ;
+ERROR: read-only-slot slot ;
+
 : check-set-slot ( val slot -- val offset )
     {
-        { [ dup not ] [ "No such slot" throw ] }
+        { [ dup not ] [ no-such-slot ] }
-        { [ dup read-only>> ] [ "Read only slot" throw ] }
+        { [ dup read-only>> ] [ read-only-slot ] }
         { [ 2dup class>> instance? not ] [ class>> bad-slot-value ] }
         [ offset>> ]
     } cond ; inline

basis/models/models.factor

@@ -20,10 +20,10 @@ value connections dependencies ref locked? ;
 M: model hashcode* drop model hashcode* ;
 
 : add-dependency ( dep model -- )
-    model-dependencies push ;
+    dependencies>> push ;
 
 : remove-dependency ( dep model -- )
-    model-dependencies delete ;
+    dependencies>> delete ;
 
 DEFER: add-connection
 
@@ -32,14 +32,14 @@ GENERIC: model-activated ( model -- )
 M: model model-activated drop ;
 
 : ref-model ( model -- n )
-    dup model-ref 1+ dup rot set-model-ref ;
+    [ 1+ ] change-ref ref>> ;
 
 : unref-model ( model -- n )
-    dup model-ref 1- dup rot set-model-ref ;
+    [ 1- ] change-ref ref>> ;
 
 : activate-model ( model -- )
     dup ref-model 1 = [
-        dup model-dependencies
+        dup dependencies>>
         [ dup activate-model dupd add-connection ] each
         model-activated
     ] [
@@ -50,7 +50,7 @@ DEFER: remove-connection
 
 : deactivate-model ( model -- )
     dup unref-model zero? [
-        dup model-dependencies
+        dup dependencies>>
         [ dup deactivate-model remove-connection ] with each
     ] [
         drop
@@ -59,46 +59,45 @@ DEFER: remove-connection
 GENERIC: model-changed ( model observer -- )
 
 : add-connection ( observer model -- )
-    dup model-connections empty? [ dup activate-model ] when
+    dup connections>> empty? [ dup activate-model ] when
-    model-connections push ;
+    connections>> push ;
 
 : remove-connection ( observer model -- )
-    [ model-connections delete ] keep
+    [ connections>> delete ] keep
-    dup model-connections empty? [ dup deactivate-model ] when
+    dup connections>> empty? [ dup deactivate-model ] when
     drop ;
 
 : with-locked-model ( model quot -- )
     swap
-    t over set-model-locked?
+    t >>locked?
     slip
-    f swap set-model-locked? ; inline
+    f >>locked? drop ; inline
 
 GENERIC: update-model ( model -- )
 
 M: model update-model drop ;
 
 : notify-connections ( model -- )
-    dup model-connections [ model-changed ] with each ;
+    dup connections>> [ model-changed ] with each ;
 
 : set-model ( value model -- )
-    dup model-locked? [
+    dup locked?>> [
         2drop
     ] [
         dup [
-            [ set-model-value ] keep
+            swap >>value
-            [ update-model ] keep
+            [ update-model ] [ notify-connections ] bi
-            notify-connections
         ] with-locked-model
     ] if ;
 
 : ((change-model)) ( model quot -- newvalue model )
-    over >r >r model-value r> call r> ; inline
+    over >r >r value>> r> call r> ; inline
 
 : change-model ( model quot -- )
     ((change-model)) set-model ; inline
 
 : (change-model) ( model quot -- )
-    ((change-model)) set-model-value ; inline
+    ((change-model)) (>>value) ; inline
 
 GENERIC: range-value ( model -- value )
 GENERIC: range-page-value ( model -- value )

basis/opengl/opengl-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax io kernel math quotations
-opengl.gl assocs vocabs.loader sequences ;
+opengl.gl assocs vocabs.loader sequences accessors ;
 IN: opengl
 
 HELP: gl-color
@@ -91,17 +91,17 @@ HELP: do-attribs
 HELP: sprite
 { $class-description "A sprite is an OpenGL texture together with a display list which renders a textured quad. Sprites are used to draw text in the UI. Sprites have the following slots:"
     { $list
-        { { $link sprite-dlist } " - an OpenGL display list ID" }
+        { { $snippet "dlist" } " - an OpenGL display list ID" }
-        { { $link sprite-texture } " - an OpenGL texture ID" }
+        { { $snippet "texture" } " - an OpenGL texture ID" }
-        { { $link sprite-loc } " - top-left corner of the sprite" }
+        { { $snippet "loc" } " - top-left corner of the sprite" }
-        { { $link sprite-dim } " - dimensions of the sprite" }
+        { { $snippet "dim" } " - dimensions of the sprite" }
-        { { $link sprite-dim2 } " - dimensions of the sprite, rounded up to the nearest powers of two" }
+        { { $snippet "dim2" } " - dimensions of the sprite, rounded up to the nearest powers of two" }
     }
 } ;
 
 HELP: gray-texture
 { $values { "sprite" sprite } { "pixmap" "an alien or byte array" } { "id" "an OpenGL texture ID" } }
-{ $description "Creates a new OpenGL texture from a 1 byte per pixel image whose dimensions are equal to " { $link sprite-dim2 } "." } ;
+{ $description "Creates a new OpenGL texture from a 1 byte per pixel image whose dimensions are equal to " { $snippet "dim2" } "." } ;
 
 HELP: gen-dlist
 { $values { "id" integer } }

basis/opengl/opengl.factor

@@ -180,9 +180,9 @@ TUPLE: sprite loc dim dim2 dlist texture ;
 : <sprite> ( loc dim dim2 -- sprite )
     f f sprite boa ;
 
-: sprite-size2 ( sprite -- w h ) sprite-dim2 first2 ;
+: sprite-size2 ( sprite -- w h ) dim2>> first2 ;
 
-: sprite-width ( sprite -- w ) sprite-dim first ;
+: sprite-width ( sprite -- w ) dim>> first ;
 
 : gray-texture ( sprite pixmap -- id )
     gen-texture [
@@ -223,10 +223,10 @@ PRIVATE>
     dup top-left dup top-right dup bottom-right bottom-left ;
 
 : draw-sprite ( sprite -- )
-    dup sprite-loc gl-translate
+    dup loc>> gl-translate
-    GL_TEXTURE_2D over sprite-texture glBindTexture
+    GL_TEXTURE_2D over texture>> glBindTexture
     init-texture
-    GL_QUADS [ sprite-dim2 four-sides ] do-state
+    GL_QUADS [ dim2>> four-sides ] do-state
     GL_TEXTURE_2D 0 glBindTexture ;
 
 : rect-vertices ( lower-left upper-right -- )
@@ -243,14 +243,14 @@ PRIVATE>
     ] do-matrix ;
 
 : init-sprite ( texture sprite -- )
-    [ set-sprite-texture ] keep
+    swap >>texture
-    [ make-sprite-dlist ] keep set-sprite-dlist ;
+    dup make-sprite-dlist >>dlist drop ;
 
 : delete-dlist ( id -- ) 1 glDeleteLists ;
 
 : free-sprite ( sprite -- )
-    dup sprite-dlist delete-dlist
+    [ dlist>> delete-dlist ]
-    sprite-texture delete-texture ;
+    [ texture>> delete-texture ] bi ;
 
 : free-sprites ( sprites -- )
     [ nip [ free-sprite ] when* ] assoc-each ;

basis/peg/parsers/parsers.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences strings namespaces math assocs shuffle 
-     vectors arrays math.parser 
+     vectors arrays math.parser accessors
      unicode.categories sequences.deep peg peg.private 
      peg.search math.ranges words ;
 IN: peg.parsers
@@ -11,7 +11,7 @@ TUPLE: just-parser p1 ;
 : just-pattern
   [
     execute dup [
-      dup parse-result-remaining empty? [ drop f ] unless
+      dup remaining>> empty? [ drop f ] unless
     ] when
   ] ;
 

basis/prettyprint/prettyprint-tests.factor

@@ -2,7 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex
 kernel math namespaces parser prettyprint prettyprint.config
 prettyprint.sections sequences tools.test vectors words
 effects splitting generic.standard prettyprint.private
-continuations generic compiler.units tools.walker eval ;
+continuations generic compiler.units tools.walker eval
+accessors ;
 IN: prettyprint.tests
 
 [ "4" ] [ 4 unparse ] unit-test
@@ -296,7 +297,7 @@ M: class-see-layout class-see-layout ;
     [ \ class-see-layout see-methods ] with-string-writer "\n" split
 ] unit-test
 
-[ ] [ \ effect-in synopsis drop ] unit-test
+[ ] [ \ in>> synopsis drop ] unit-test
 
 ! Regression
 [ t ] [

basis/smtp/smtp-docs.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel quotations help.syntax help.markup
+io.sockets strings calendar ;
+IN: smtp
+
+HELP: smtp-server
+{ $description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
+
+HELP: smtp-read-timeout
+{ $description "Holds an " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
+
+HELP: with-smtp-connection
+{ $values { "quot" quotation } }
+{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." } ;
+
+HELP: <email>
+{ $values { "email" email } }
+{ $description "Creates an empty " { $link email } " object." } ;
+
+HELP: send-email
+{ $values { "email" email } }
+{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable.  The required slots are " { $snippet "from" } " and " { $snippet "to" } "." }
+
+{ $examples
+    { $unchecked-example "USING: accessors smtp ;"
+    "<email>"
+    "    \"groucho@marx.bros\" >>from"
+    "    { \"chico@marx.bros\" \"harpo@marx.bros\" } >>to"
+    "    { \"gummo@marx.bros\" } >>cc"
+    "    { \"zeppo@marx.bros\" } >>bcc"
+    "    \"Pickup line\" >>subject"
+    "    \"If I said you had a beautiful body, would you hold it against me?\" >>body"
+    "send-email"
+    ""
+    }
+} ;
+
+ARTICLE: "smtp" "SMTP Client Library"
+"Start by creating a new email object:"
+{ $subsection <email> }
+"Set the " { $snippet "from" } " slot to a " { $link string } "." $nl
+"Set the recipient fields, " { $snippet "to" } ", " { $snippet "cc" } ", and " { $snippet "bcc" } ", to arrays of strings."
+"Set the " { $snippet "subject" } " to a " { $link string } "." $nl
+"Set the " { $snippet "body" } " to a " { $link string } "." $nl ;

basis/smtp/smtp-tests.factor

@@ -1,6 +1,6 @@
 USING: smtp tools.test io.streams.string io.sockets threads
 smtp.server kernel sequences namespaces logging accessors
-assocs sorting ;
+assocs sorting smtp.private ;
 IN: smtp.tests
 
 { 0 0 } [ [ ] with-smtp-connection ] must-infer-as

basis/smtp/smtp.factor

@@ -1,5 +1,5 @@
 ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
-! Slava Pestov.
+! Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays namespaces io io.timeouts kernel logging io.sockets
 sequences combinators sequences.lib splitting assocs strings
@@ -9,7 +9,7 @@ IN: smtp
 
 SYMBOL: smtp-domain
 SYMBOL: smtp-server     "localhost" "smtp" <inet> smtp-server set-global
-SYMBOL: read-timeout    1 minutes read-timeout set-global
+SYMBOL: smtp-read-timeout    1 minutes smtp-read-timeout set-global
 SYMBOL: esmtp           t esmtp set-global
 
 LOG: log-smtp-connection NOTICE ( addrspec -- )
@@ -19,7 +19,7 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
     dup log-smtp-connection
     ascii [
         smtp-domain [ host-name or ] change
-        read-timeout get timeouts
+        smtp-read-timeout get timeouts
         call
     ] with-client ; inline
 
@@ -33,6 +33,7 @@ TUPLE: email
 
 : <email> ( -- email ) email new ;
 
+<PRIVATE
 : crlf ( -- ) "\r\n" write ;
 
 : command ( string -- ) write crlf flush ;
@@ -151,7 +152,7 @@ ERROR: invalid-header-string string ;
     ] "" make ;
 
 : extract-email ( recepient -- email )
-    #! This could be much smarter.
+    ! This could be much smarter.
     " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
 
 : email>headers ( email -- hashtable )
@@ -179,6 +180,7 @@ ERROR: invalid-header-string string ;
         body>> send-body get-ok
         quit get-ok
     ] with-smtp-connection ;
+PRIVATE>
 
 : send-email ( email -- )
     [ email>headers ] keep (send-email) ;
@@ -200,5 +202,3 @@ ERROR: invalid-header-string string ;
 ! : cram-md5-auth ( key login  -- )
 !     "AUTH CRAM-MD5\r\n" get-ok 
 !     (cram-md5-auth) "\r\n" append get-ok ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

basis/tools/annotations/annotations.factor

@@ -31,7 +31,7 @@ M: word reset
 
 : word-inputs ( word -- seq )
     stack-effect [
-        >r datastack r> effect-in length tail*
+        >r datastack r> in>> length tail*
     ] [
         datastack
     ] if* ;
@@ -44,7 +44,7 @@ M: word reset
 : leaving ( str -- )
     "/-- Leaving: " write dup .
     stack-effect [
-        >r datastack r> effect-out length tail* stack.
+        >r datastack r> out>> length tail* stack.
     ] [
         .s
     ] if* "\\--" print flush ;

basis/tools/threads/threads.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: threads kernel prettyprint prettyprint.config
 io io.styles sequences assocs namespaces sorting boxes
-heaps.private system math math.parser math.order ;
+heaps.private system math math.parser math.order accessors ;
 IN: tools.threads
 
 : thread. ( thread -- )
@@ -14,7 +14,7 @@ IN: tools.threads
     ] with-cell
     [
         thread-sleep-entry [
-            entry-key millis [-] number>string write
+            key>> millis [-] number>string write
             " ms" write
         ] when*
     ] with-cell ;

core/alien/alien.factor

@@ -53,7 +53,7 @@ TUPLE: library path abi dll ;
     over dup [ dlopen ] when \ library boa ;
 
 : load-library ( name -- dll )
-    library dup [ library-dll ] when ;
+    library dup [ dll>> ] when ;
 
 : add-library ( name path abi -- )
     <library> swap libraries get set-at ;

core/classes/algebra/algebra-tests.factor

@@ -4,7 +4,7 @@ tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
 random stack-checker effects kernel.private sbufs math.order
-classes.tuple ;
+classes.tuple accessors ;
 IN: classes.algebra.tests
 
 \ class< must-infer
@@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
 10 [
     [ ] [
         20 [ random-op ] [ ] replicate-as
-        [ infer effect-in [ random-class ] times ] keep
+        [ infer in>> [ random-class ] times ] keep
         call
         drop
     ] unit-test
@@ -238,7 +238,7 @@ UNION: z1 b1 c1 ;
 20 [
     [ t ] [
         20 [ random-boolean-op ] [ ] replicate-as dup .
-        [ infer effect-in [ random-boolean ] replicate dup . ] keep
+        [ infer in>> [ random-boolean ] replicate dup . ] keep
         
         [ >r [ ] each r> call ] 2keep
         

core/io/files/files.factor

@@ -324,7 +324,7 @@ TUPLE: pathname string ;
 
 C: <pathname> pathname
 
-M: pathname <=> [ pathname-string ] compare ;
+M: pathname <=> [ string>> ] compare ;
 
 ! Home directory
 HOOK: home os ( -- dir )

core/lexer/lexer.factor

@@ -29,8 +29,8 @@ TUPLE: lexer text line line-text line-length column ;
 
 : change-lexer-column ( lexer quot -- )
     swap
-    [ dup lexer-column swap lexer-line-text rot call ] keep
+    [ [ column>> ] [ line-text>> ] bi rot call ] keep
-    set-lexer-column ; inline
+    (>>column) ; inline
 
 GENERIC: skip-blank ( lexer -- )
 
@@ -45,16 +45,18 @@ M: lexer skip-word ( lexer -- )
     ] change-lexer-column ;
 
 : still-parsing? ( lexer -- ? )
-    dup lexer-line swap lexer-text length <= ;
+    [ line>> ] [ text>> ] bi length <= ;
 
 : still-parsing-line? ( lexer -- ? )
-    dup lexer-column swap lexer-line-length < ;
+    [ column>> ] [ line-length>> ] bi < ;
 
 : (parse-token) ( lexer -- str )
-    [ lexer-column ] keep
+    {
-    [ skip-word ] keep
+        [ column>> ]
-    [ lexer-column ] keep
+        [ skip-word ]
-    lexer-line-text subseq ;
+        [ column>> ]
+        [ line-text>> ]
+    } cleave subseq ;
 
 :  parse-token ( lexer -- str/f )
     dup still-parsing? [
@@ -68,7 +70,7 @@ M: lexer skip-word ( lexer -- )
 ERROR: unexpected want got ;
 
 PREDICATE: unexpected-eof < unexpected
-    unexpected-got not ;
+    got>> not ;
 
 : unexpected-eof ( word -- * ) f unexpected ;
 

core/words/words-docs.factor

@@ -124,13 +124,11 @@ $nl
 
     { { { $snippet "\"inferred-effect\"" } } { $link "inference" } }
 
-    { { $snippet "\"specializer\"" } { $link "specializers" } }
+    { { $snippet "\"specializer\"" } { $link "hints" } }
     
     { { { $snippet "\"intrinsics\"" } ", " { $snippet "\"if-intrinsics\"" } } { $link "generator" } }
 
     { { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }
-    
-    { { { $snippet "\"constructing\"" } ", " { $snippet "\"constructor-quot\"" } } { $link "tuple-constructors" } }
 }
 "Properties which are defined for classes only:"
 { $table
@@ -163,12 +161,12 @@ ARTICLE: "words" "Words"
 $nl
 "Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary."
 $nl
-"A word consists of several parts:"
+"Word objects contain several slots:"
-{ $list
+{ $table
-    "a word name,"
+    { { $snippet "name" } "a word name" }
-    "a vocabulary name,"
+    { { $snippet "vocabulary" } "a word vocabulary name" }
-    "a definition quotation, called when the word when executed,"
+    { { $snippet "def" } "a definition quotation" }
-    "a set of word properties, including documentation and other meta-data."
+    { { $snippet "props" } "an assoc of word properties, including documentation and other meta-data" }
 }
 "Words are instances of a class."
 { $subsection word }

extra/combinators/lib/lib.factor

@@ -4,7 +4,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel combinators fry namespaces quotations hashtables
 sequences assocs arrays stack-checker effects math math.ranges
-generalizations macros continuations random locals ;
+generalizations macros continuations random locals accessors ;
 
 IN: combinators.lib
 
@@ -63,7 +63,7 @@ IN: combinators.lib
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 MACRO: preserving ( predicate -- quot )
-    dup infer effect-in
+    dup infer in>>
     dup 1+
     '[ , , nkeep , nrot ] ;
 

extra/inverse/inverse.factor

@@ -40,8 +40,8 @@ M: no-inverse summary
 
 : constant-word? ( word -- ? )
     stack-effect
-    [ effect-out length 1 = ] keep
+    [ out>> length 1 = ] keep
-    effect-in length 0 = and ;
+    in>> length 0 = and ;
 
 : assure-constant ( constant -- quot )
     dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
@@ -65,7 +65,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
 : enough? ( stack word -- ? )
     dup deferred? [ 2drop f ] [
-        [ >r length r> 1quotation infer effect-in >= ]
+        [ >r length r> 1quotation infer in>> >= ]
         [ 3drop f ] recover
     ] if ;
 
@@ -235,11 +235,11 @@ DEFER: _
     ] recover ; inline
 
 : true-out ( quot effect -- quot' )
-    effect-out [ ndrop ] curry
+    out>> [ ndrop ] curry
     [ t ] 3compose ;
 
 : false-recover ( effect -- quot )
-    effect-in [ ndrop f ] curry [ recover-fail ] curry ;
+    in>> [ ndrop f ] curry [ recover-fail ] curry ;
 
 : [matches?] ( quot -- undoes?-quot )
     [undo] dup infer [ true-out ] keep false-recover curry ;

extra/promises/promises.factor

@@ -5,7 +5,7 @@
 ! Updated by Chris Double, September 2006
 
 USING: arrays kernel sequences math vectors arrays namespaces
-quotations parser effects stack-checker words ;
+quotations parser effects stack-checker words accessors ;
 IN: promises
 
 TUPLE: promise quot forced? value ;
@@ -23,14 +23,14 @@ TUPLE: promise quot forced? value ;
     #! Force the given promise leaving the value of calling the
     #! promises quotation on the stack. Re-forcing the promise
     #! will return the same value and not recall the quotation.
-    dup promise-forced? [
+    dup forced?>> [
-        dup promise-quot call over set-promise-value
+        dup quot>> call >>value
-        t over set-promise-forced?
+        t >>forced?
     ] unless
-    promise-value ;
+    value>> ;
 
 : stack-effect-in ( quot word -- n )
-  stack-effect [ ] [ infer ] ?if effect-in length ;
+  stack-effect [ ] [ infer ] ?if in>> length ;
 
 : make-lazy-quot ( word quot -- quot )
   [

unfinished/regexp2/backend/backend.factor

@@ -11,6 +11,8 @@ TUPLE: regexp
     nfa-table
     dfa-table
     minimized-table
+    { nfa-traversal-flags hashtable }
+    { dfa-traversal-flags hashtable }
     { state integer }
     { new-states vector }
     { visited-states hashtable } ;

unfinished/regexp2/dfa/dfa.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry kernel locals
 math math.order regexp2.nfa regexp2.transition-tables sequences
-sets sorting vectors regexp2.utils sequences.lib ;
+sets sorting vectors regexp2.utils sequences.lib combinators.lib
+sequences.deep ;
 USING: io prettyprint threads ;
 IN: regexp2.dfa
 
@@ -42,7 +43,7 @@ IN: regexp2.dfa
         dupd pop dup pick find-transitions rot
         [
             [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
-            >r swapd transition boa r> dfa-table>> add-transition 
+            >r swapd transition make-transition r> dfa-table>> add-transition 
         ] curry with each
         new-transitions
     ] if-empty ;
@@ -66,5 +67,13 @@ IN: regexp2.dfa
     [ >>start-state drop ] keep
     1vector >>new-states drop ;
 
+: set-traversal-flags ( regexp -- )
+    [ dfa-table>> transitions>> keys ]
+    [ nfa-traversal-flags>> ]
+    bi 2drop ;
+
 : construct-dfa ( regexp -- )
-    [ set-initial-state ] [ new-transitions ] [ set-final-states ] tri ;
+    [ set-initial-state ]
+    [ new-transitions ]
+    [ set-final-states ] tri ;
+    ! [ set-traversal-flags ] quad ;

unfinished/regexp2/nfa/nfa.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs grouping kernel regexp2.backend
 locals math namespaces regexp2.parser sequences state-tables fry
 quotations math.order math.ranges vectors unicode.categories
-regexp2.utils regexp2.transition-tables words sequences.lib ;
+regexp2.utils regexp2.transition-tables words sequences.lib sets ;
 IN: regexp2.nfa
 
 SYMBOL: negation-mode
@@ -11,6 +11,12 @@ SYMBOL: negation-mode
 
 SINGLETON: eps
 
+MIXIN: traversal-flag
+SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
+SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
+SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
+SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
+
 : next-state ( regexp -- state )
     [ state>> ] [ [ 1+ ] change-state drop ] bi ;
 
@@ -30,14 +36,18 @@ GENERIC: nfa-node ( node -- )
             stack [ regexp stack>> ]
             table [ regexp nfa-table>> ] |
         negated? [
-            s0 f obj class boa table add-transition
+            s0 f obj class make-transition table add-transition
             s0 s1 <default-transition> table add-transition
         ] [
-            s0 s1 obj class boa table add-transition
+            s0 s1 obj class make-transition table add-transition
         ] if
         s0 s1 2array stack push
         t s1 table final-states>> set-at ] ;
 
+: add-traversal-flag ( flag -- )
+    stack peek second
+    current-regexp get nfa-traversal-flags>> push-at ;
+
 :: concatenate-nodes ( -- )
     [let* | regexp [ current-regexp get ]
             stack [ regexp stack>> ]
@@ -116,6 +126,14 @@ M: negation nfa-node ( node -- )
     term>> nfa-node 
     negation-mode dec ;
 
+M: lookahead nfa-node ( node -- )
+    eps literal-transition add-simple-entry
+    lookahead-on add-traversal-flag
+    term>> nfa-node
+    eps literal-transition add-simple-entry
+    lookahead-off add-traversal-flag
+    2 [ concatenate-nodes ] times ;
+
 : construct-nfa ( regexp -- )
     [
         reset-regexp

unfinished/regexp2/parser/parser.factor

@@ -151,11 +151,13 @@ ERROR: bad-special-group string ;
 DEFER: nested-parse-regexp
 : (parse-special-group) ( -- )
     read1 {
+        { [ dup CHAR: # = ]
+            [ drop nested-parse-regexp pop-stack drop ] }
         { [ dup CHAR: : = ]
             [ drop nested-parse-regexp pop-stack make-non-capturing-group ] }
         { [ dup CHAR: = = ]
             [ drop nested-parse-regexp pop-stack make-positive-lookahead ] }
-        { [ dup CHAR: = = ]
+        { [ dup CHAR: ! = ]
             [ drop nested-parse-regexp pop-stack make-negative-lookahead ] }
         { [ dup CHAR: > = ]
             [ drop nested-parse-regexp pop-stack make-independent-group ] }
@@ -385,25 +387,25 @@ DEFER: handle-left-bracket
 : nested-parse-regexp ( -- )
     beginning-of-group push-stack (parse-regexp) ;
 
-: ((parse-regexp)) ( token -- )
+: ((parse-regexp)) ( token -- ? )
     {
-        { CHAR: . [ handle-dot ] }
+        { CHAR: . [ handle-dot t ] }
-        { CHAR: ( [ handle-left-parenthesis ] }
+        { CHAR: ( [ handle-left-parenthesis t ] }
-        { CHAR: ) [ handle-right-parenthesis ] }
+        { CHAR: ) [ handle-right-parenthesis f ] }
-        { CHAR: | [ handle-pipe ] }
+        { CHAR: | [ handle-pipe t ] }
-        { CHAR: ? [ handle-question ] }
+        { CHAR: ? [ handle-question t ] }
-        { CHAR: * [ handle-star ] }
+        { CHAR: * [ handle-star t ] }
-        { CHAR: + [ handle-plus ] }
+        { CHAR: + [ handle-plus t ] }
-        { CHAR: { [ handle-left-brace ] }
+        { CHAR: { [ handle-left-brace t ] }
-        { CHAR: [ [ handle-left-bracket ] }
+        { CHAR: [ [ handle-left-bracket t ] }
-        { CHAR: ^ [ handle-front-anchor ] }
+        { CHAR: ^ [ handle-front-anchor t ] }
-        { CHAR: $ [ handle-back-anchor ] }
+        { CHAR: $ [ handle-back-anchor t ] }
-        { CHAR: \ [ handle-escape ] }
+        { CHAR: \ [ handle-escape t ] }
-        [ <constant> push-stack ]
+        [ <constant> push-stack t ]
     } case ;
 
 : (parse-regexp) ( -- )
-    read1 [ ((parse-regexp)) (parse-regexp) ] when* ;
+    read1 [ ((parse-regexp)) [ (parse-regexp) ] when ] when* ;
 
 : parse-regexp ( regexp -- )
     dup current-regexp [

unfinished/regexp2/regexp2-tests.factor

@@ -222,6 +222,8 @@ IN: regexp2-tests
     <regexp> drop
 ] unit-test
 
+! Comment
+[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
 
 
 

unfinished/regexp2/regexp2.factor

@@ -12,6 +12,8 @@ IN: regexp2
         <transition-table> >>nfa-table
         <transition-table> >>dfa-table
         <transition-table> >>minimized-table
+        H{ } clone >>nfa-traversal-flags
+        H{ } clone >>dfa-traversal-flags
         reset-regexp ;
 
 : construct-regexp ( regexp -- regexp' )
@@ -26,7 +28,8 @@ IN: regexp2
     <dfa-traverser> do-match return-match ;
 
 : matches? ( string regexp -- ? )
-    dupd match [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
+    dupd match
+    [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
 
 : match-head ( string regexp -- end ) match length>> 1- ;
 

unfinished/regexp2/transition-tables/transition-tables.factor

@@ -1,19 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry hashtables kernel sequences
-vectors ;
+vectors regexp2.utils ;
 IN: regexp2.transition-tables
 
-: insert-at ( value key hash -- )
-    2dup at* [
-        2nip push
-    ] [
-        drop >r >r dup vector? [ 1vector ] unless r> r> set-at
-    ] if ;
-
-: ?insert-at ( value key hash/f -- hash )
-    [ H{ } clone ] unless* [ insert-at ] keep ;
-
 TUPLE: transition from to obj ;
 TUPLE: literal-transition < transition ;
 TUPLE: class-transition < transition ;
@@ -22,13 +12,20 @@ TUPLE: default-transition < transition ;
 TUPLE: literal obj ;
 TUPLE: class obj ;
 TUPLE: default ;
-: <literal-transition> ( from to obj -- transition ) literal-transition boa ;
+: make-transition ( from to obj class -- obj )
-: <class-transition> ( from to obj -- transition ) class-transition boa ;
+    new
-: <default-transition> ( from to -- transition ) t default-transition boa ;
+        swap >>obj
+        swap >>to
+        swap >>from ;
 
-TUPLE: transition-table transitions
+: <literal-transition> ( from to obj -- transition )
-    literals classes defaults
+    literal-transition make-transition ;
-    start-state final-states ;
+: <class-transition> ( from to obj -- transition )
+    class-transition make-transition ;
+: <default-transition> ( from to -- transition )
+    t default-transition make-transition ;
+
+TUPLE: transition-table transitions start-state final-states ;
 
 : <transition-table> ( -- transition-table )
     transition-table new
@@ -36,7 +33,7 @@ TUPLE: transition-table transitions
         H{ } clone >>final-states ;
 
 : set-transition ( transition hash -- )
-    >r [ to>> ] [ obj>> ] [ from>> ] tri r>
+    [ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
     2dup at* [ 2nip insert-at ]
     [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;
 

unfinished/regexp2/traversal/traversal.factor

@@ -3,25 +3,31 @@
 USING: accessors assocs combinators combinators.lib kernel
 math math.ranges quotations sequences regexp2.parser
 regexp2.classes combinators.short-circuit assocs.lib
-sequences.lib ;
+sequences.lib regexp2.utils ;
 IN: regexp2.traversal
 
 TUPLE: dfa-traverser
     dfa-table
+    traversal-flags
+    capture-groups
+    { capture-group-index integer }
+    { lookahead-counter integer }
     last-state current-state
     text
     start-index current-index
     matches ;
 
 : <dfa-traverser> ( text regexp -- match )
-    dfa-table>>
+    [ dfa-table>> ] [ traversal-flags>> ] bi
     dfa-traverser new
+        swap >>traversal-flags
         swap [ start-state>> >>current-state ] keep
         >>dfa-table
         swap >>text
         0 >>start-index
         0 >>current-index
-        V{ } clone >>matches ;
+        V{ } clone >>matches
+        V{ } clone >>capture-groups ;
 
 : final-state? ( dfa-traverser -- ? )
     [ current-state>> ] [ dfa-table>> final-states>> ] bi
@@ -39,8 +45,7 @@ TUPLE: dfa-traverser
     ] when text-finished? ;
 
 : increment-state ( dfa-traverser state -- dfa-traverser )
-    >r [ 1+ ] change-current-index
+    >r [ 1+ ] change-current-index dup current-state>> >>last-state r>
-    dup current-state>> >>last-state r>
     first >>current-state ;
 
 : match-failed ( dfa-traverser -- dfa-traverser )
@@ -49,9 +54,6 @@ TUPLE: dfa-traverser
 : match-literal ( transition from-state table -- to-state/f )
     transitions>> [ at ] [ 2drop f ] if-at ;
 
-: assoc-with ( param assoc quot -- assoc curry )
-    swapd [ [ -rot ] dip call ] 2curry ; inline
-
 : match-class ( transition from-state table -- to-state/f )
     transitions>> at* [
         [ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
@@ -65,7 +67,10 @@ TUPLE: dfa-traverser
     { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
 
 : setup-match ( match -- obj state dfa-table )
-    { current-index>> text>> current-state>> dfa-table>> } get-slots
+    {
+        [ current-index>> ] [ text>> ]
+        [ current-state>> ] [ dfa-table>> ]
+    } cleave
     [ nth ] 2dip ;
 
 : do-match ( dfa-traverser -- dfa-traverser )

unfinished/regexp2/utils/utils.factor

@@ -3,18 +3,32 @@
 USING: accessors arrays assocs combinators.lib io kernel
 math math.order namespaces regexp2.backend sequences
 sequences.lib unicode.categories math.ranges fry
-combinators.short-circuit ;
+combinators.short-circuit vectors ;
 IN: regexp2.utils
 
 : (while-changes) ( obj quot pred pred-ret -- obj )
     ! quot: ( obj -- obj' )
     ! pred: ( obj -- <=> )
     >r >r dup slip r> pick over call r> dupd =
-    [ 3drop ] [ (while-changes) ] if ; inline
+    [ 3drop ] [ (while-changes) ] if ; inline recursive
 
 : while-changes ( obj quot pred -- obj' )
     pick over call (while-changes) ; inline
 
+: assoc-with ( param assoc quot -- assoc curry )
+    swapd [ [ -rot ] dip call ] 2curry ; inline
+
+: insert-at ( value key hash -- )
+    2dup at* [
+        2nip push
+    ] [
+        drop
+        [ dup vector? [ 1vector ] unless ] 2dip set-at
+    ] if ;
+
+: ?insert-at ( value key hash/f -- hash )
+    [ H{ } clone ] unless* [ insert-at ] keep ;
+
 : last-state ( regexp -- range ) stack>> peek first2 [a,b] ;
 : push1 ( obj -- ) input-stream get stream>> push ;
 : peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;