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,17 @@
+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 "USING: alias prettyprint sequences ;"
+               "IN: alias.test"
+               "ALIAS: sequence-nth nth"
+               "0 { 10 20 30 } sequence-nth ."
+               "10"
+    }
+} ;
+
+

basis/alias/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/alien/structs/structs-docs.factor

@@ -1,13 +1,13 @@
 IN: alien.structs
 USING: alien.c-types strings help.markup help.syntax
 alien.syntax sequences io arrays slots.deprecated
-kernel words slots assocs namespaces ;
+kernel words slots assocs namespaces accessors ;
 
 ! Deprecated code
 : ($spec-reader-values) ( slot-spec class -- element )
     dup ?word-name swap 2array
-    over slot-spec-name
+    over name>>
-    rot slot-spec-class 2array 2array
+    rot class>> 2array 2array
     [ { $instance } swap suffix ] assoc-map ;
 
 : $spec-reader-values ( slot-spec class -- )
@@ -16,14 +16,14 @@ kernel words slots assocs namespaces ;
 : $spec-reader-description ( slot-spec class -- )
     [
         "Outputs the value stored in the " ,
-        { $snippet } rot slot-spec-name suffix ,
+        { $snippet } rot name>> suffix ,
         " slot of " ,
         { $instance } swap suffix ,
         " instance." ,
     ] { } make $description ;
 
 : slot-of-reader ( reader specs -- spec/f )
-    [ slot-spec-reader eq? ] with find nip ;
+    [ reader>> eq? ] with find nip ;
 
 : $spec-reader ( reader slot-specs class -- )
     >r slot-of-reader r>
@@ -46,14 +46,14 @@ M: word slot-specs "slots" word-prop ;
 : $spec-writer-description ( slot-spec class -- )
     [
         "Stores a new value to the " ,
-        { $snippet } rot slot-spec-name suffix ,
+        { $snippet } rot name>> suffix ,
         " slot of " ,
         { $instance } swap suffix ,
         " instance." ,
     ] { } make $description ;
 
 : slot-of-writer ( writer specs -- spec/f )
-    [ slot-spec-writer eq? ] with find nip ;
+    [ writer>> eq? ] with find nip ;
 
 : $spec-writer ( writer slot-specs class -- )
     >r slot-of-writer r>

basis/alien/structs/structs.factor

@@ -11,17 +11,17 @@ IN: alien.structs
 : struct-offsets ( specs -- size )
     0 [
         [ class>> align-offset ] keep
-        [ set-slot-spec-offset ] 2keep
+        [ (>>offset) ] 2keep
         class>> heap-size +
     ] reduce ;
 
 : define-struct-slot-word ( spec word quot -- )
-    rot slot-spec-offset prefix define-inline ;
+    rot offset>> prefix define-inline ;
 
 : define-getter ( type spec -- )
     [ set-reader-props ] keep
     [ ]
-    [ slot-spec-reader ]
+    [ reader>> ]
     [
         class>>
         [ c-getter ] [ c-type c-type-boxer-quot ] bi append
@@ -31,7 +31,7 @@ IN: alien.structs
 : define-setter ( type spec -- )
     [ set-writer-props ] keep
     [ ]
-    [ slot-spec-writer ]
+    [ writer>> ]
     [ class>> c-setter ] tri
     define-struct-slot-word ;
 

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
@@ -244,13 +244,13 @@ ERROR: invalid-timestamp-format ;
     [ (ymdhms>timestamp) ] with-string-reader ;
 
 : (hms>timestamp) ( -- timestamp )
-    f f f read-hms instant <timestamp> ;
+    0 0 0 read-hms instant <timestamp> ;
 
 : hms>timestamp ( str -- timestamp )
     [ (hms>timestamp) ] with-string-reader ;
 
 : (ymd>timestamp) ( -- timestamp )
-    read-ymd f f f instant <timestamp> ;
+    read-ymd 0 0 0 instant <timestamp> ;
 
 : ymd>timestamp ( str -- timestamp )
     [ (ymd>timestamp) ] with-string-reader ;

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/iterator/iterator.factor

@@ -37,9 +37,9 @@ DEFER: (tail-call?)
 : tail-call? ( -- ? )
     node-stack get [
         rest-slice
-        dup [
+        dup empty? [ drop t ] [
             [ (tail-call?) ]
             [ first #terminate? not ]
             bi and
-        ] [ drop t ] if
+        ] if
     ] all? ;

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/intrinsics.factor

@@ -450,3 +450,14 @@ cell 8 = [
 [ 8 ] [
     1 [ 3 fixnum-shift-fast ] compile-call
 ] unit-test
+
+TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
+
+[ B{ 0 1 } ] [
+    B{ 0 0 } 1 alien-accessor-regression boa
+    dup [
+        { alien-accessor-regression } declare
+        [ i>> ] [ b>> ] bi over set-alien-unsigned-1
+    ] compile-call
+    b>>
+] unit-test

basis/compiler/tests/optimizer.factor

@@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences
 sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
-compiler.tree.builder compiler.tree.optimizer ;
+compiler.tree.builder compiler.tree.optimizer sequences.deep ;
 IN: optimizer.tests
 
 GENERIC: xyz ( obj -- obj )
@@ -353,3 +353,12 @@ TUPLE: some-tuple x ;
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+
+: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
+
+[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
+[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
+
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+
+[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test

basis/compiler/tests/redefine4.factor

@@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
 
 [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
 
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
 
 [ "X" ] [ [ declaration-test ] with-string-writer ] 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

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
-classes.algebra namespaces assocs math math.private
+classes.algebra namespaces assocs words math math.private
-math.partial-dispatch classes.tuple classes.tuple.private
+math.partial-dispatch math.intervals classes classes.tuple
-definitions stack-checker.state stack-checker.branches
+classes.tuple.private layouts definitions stack-checker.state
-compiler.tree
+stack-checker.branches compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -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 )
@@ -64,9 +66,19 @@ GENERIC: cleanup* ( node -- node/nodes )
         { fixnum-shift fixnum-shift-fast }
     } at ;
 
+: (remove-overflow-check?) ( #call -- ? )
+    node-output-infos first class>> fixnum class<= ;
+
+: small-shift? ( #call -- ? )
+    node-input-infos second interval>>
+    cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ;
+
 : remove-overflow-check? ( #call -- ? )
-    dup word>> no-overflow-variant
+    {
-    [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ;
+        { [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] }
+        { [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] }
+        [ drop f ]
+    } cond ;
 
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
@@ -92,8 +104,11 @@ M: #declare cleanup* drop f ;
 : fold-only-branch ( #branch -- node/nodes )
     #! If only one branch is live we don't need to branch at
     #! all; just drop the condition value.
-    dup live-children sift dup length 1 =
+    dup live-children sift dup length {
-    [ first swap in-d>> #drop prefix ] [ drop ] if ;
+        { 0 [ 2drop f ] }
+        { 1 [ first swap in-d>> #drop prefix ] }
+        [ 2drop ]
+    } case ;
 
 SYMBOL: live-branches
 
@@ -108,15 +123,18 @@ M: #branch cleanup*
         [ live-branches>> live-branches set ]
     } cleave ;
 
+: output-fs ( values -- nodes )
+    [ f swap #push ] map ;
+
 : eliminate-single-phi ( #phi -- node )
     [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
-    [ [ drop ] [ [ f swap #push ] map ] bi* ]
+    [ [ drop ] [ output-fs ] bi* ]
     [ #copy ]
     if ;
 
 : eliminate-phi ( #phi -- node )
     live-branches get sift length {
-        { 0 [ drop f ] }
+        { 0 [ out-d>> output-fs ] }
         { 1 [ eliminate-single-phi ] }
         [ drop ]
     } case ;

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-1 ( a -- b )
     [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
 
-[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
     [ call-recursive-dce-1 ] optimize-quot squish
 ] unit-test
 
@@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests
     [ f call-recursive-dce-2 drop ] optimize-quot squish
 ] unit-test
 
-[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
     [ f call-recursive-dce-2 ] optimize-quot squish
 ] unit-test
 
@@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-4 ( a -- b )
     call-recursive-dce-4 ; inline recursive
 
-[ [ "WRAP" [ "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" ] label ] ] [
     [ call-recursive-dce-4 ] optimize-quot squish
 ] unit-test
 
@@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests
 [ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
 
 [ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
+
+: call-recursive-dce-7 ( obj -- elt ? )
+    dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
+
+[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test

basis/compiler/tree/dead-code/recursive/recursive.factor

@@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values*
     #! corresponding inputs to the #call-recursive are live also.
     [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
 
-: return-recursive-phi-in ( #return-recursive -- phi-in )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
-
 M: #return-recursive compute-live-values*
-    [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
+    [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
 
 M: #call-recursive compute-live-values*
     #! If the output of a #call-recursive is live, then the
@@ -34,15 +31,6 @@ M: #call-recursive compute-live-values*
         drop-values
     ] ;
 
-M: #recursive remove-dead-code* ( node -- nodes )
-    dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
-    {
-        [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
-        [ drop [ (remove-dead-code) ] change-child drop ]
-        [ drop label>> [ filter-live ] change-enter-out drop ]
-        [ swap 2array ]
-    } 2cleave ;
-
 M: #enter-recursive remove-dead-code*
     [ filter-live ] change-out-d ;
 
@@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code*
     [ drop-call-recursive-outputs ]
     tri 3array ;
 
-M: #return-recursive remove-dead-code* ( node -- nodes )
+:: drop-recursive-inputs ( node -- shuffle )
-    dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
+    [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
-    [ drop [ filter-live ] change-out-d drop ]
+            new-outputs [ shuffle out-d>> ] |
-    [ out-d>> >>in-d drop ]
+        node new-outputs
-    [ swap 2array ]
+        [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
-    2tri ;
+        shuffle
+    ] ;
+
+:: drop-recursive-outputs ( node -- shuffle )
+    [let* | return [ node label>> return>> ]
+            new-inputs [ return in-d>> filter-live ]
+            new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
+        return
+        [ new-inputs >>in-d new-outputs >>out-d drop ]
+        [ drop-dead-outputs ]
+        bi
+    ] ;
+
+M:: #recursive remove-dead-code* ( node -- nodes )
+    [let* | drop-inputs [ node drop-recursive-inputs ]
+            drop-outputs [ node drop-recursive-outputs ] |
+         node [ (remove-dead-code) ] change-child drop
+         node label>> [ filter-live ] change-enter-out drop
+         drop-inputs node drop-outputs 3array
+    ] ;
+
+M: #return-recursive remove-dead-code* ;

basis/compiler/tree/dead-code/simple/simple.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
-fry locals classes.algebra stack-checker.backend
+fry locals definitions classes.algebra
+stack-checker.state
+stack-checker.backend
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.dead-code.liveness ;
@@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
     ] ;
 
 : drop-dead-outputs ( node -- nodes )
-    dup out-d>> drop-dead-values
+    dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
-    [ in-d>> >>out-d drop ] [ 2array ] 2bi ;
 
 M: #introduce remove-dead-code* ( #introduce -- nodes )
-    drop-dead-outputs ;
+    dup drop-dead-outputs 2array ;
 
 M: #>r remove-dead-code*
     [ filter-live ] change-out-r
@@ -105,7 +106,9 @@ M: #push remove-dead-code*
     ] [ drop f ] if ;
 
 : remove-flushable-call ( #call -- node )
-    in-d>> #drop remove-dead-code* ;
+    [ word>> +inlined+ depends-on ]
+    [ in-d>> #drop remove-dead-code* ]
+    bi ;
 
 : some-outputs-dead? ( #call -- ? )
     out-d>> [ live-value? not ] contains? ;
@@ -115,7 +118,7 @@ M: #call remove-dead-code*
         remove-flushable-call
     ] [
         dup some-outputs-dead? [
-            drop-dead-outputs
+            dup drop-dead-outputs 2array
         ] when
     ] if ;
 

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -7,7 +7,7 @@ compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
 compiler.tree.intrinsics namespaces compiler.tree.propagation.info
-stack-checker.errors ;
+stack-checker.errors kernel.private ;
 
 \ escape-analysis must-infer
 
@@ -316,3 +316,7 @@ C: <ro-box> ro-box
     [ \ too-many->r boa f f \ inference-error boa ]
     count-unboxed-allocations
 ] unit-test
+
+[ 0 ] [
+    [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
+] unit-test

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -125,21 +125,20 @@ SYMBOL: history
 : remember-inlining ( word -- )
     history [ swap suffix ] change ;
 
-: inline-word ( #call word -- )
+: inline-word ( #call word -- ? )
     dup history get memq? [
-        2drop
+        2drop f
     ] [
         [
             dup remember-inlining
             dupd def>> splicing-nodes >>body
             propagate-body
         ] with-scope
+        t
     ] if ;
 
 : inline-method-body ( #call word -- ? )
-    2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
+    2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
 : always-inline-word? ( word -- ? )
     { curry compose } memq? ;
-
-: always-inline-word ( #call word -- ? ) inline-word t ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -571,6 +571,8 @@ MIXIN: empty-mixin
 
 [ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
 
+[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -93,7 +93,7 @@ M: #declare propagate-before
 
 : do-inlining ( #call word -- ? )
     {
-        { [ dup always-inline-word? ] [ always-inline-word ] }
+        { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup math-partial? ] [ inline-math-partial ] }

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/locks/locks-tests.factor

@@ -1,7 +1,7 @@
 IN: concurrency.locks.tests
 USING: tools.test concurrency.locks concurrency.count-downs
 concurrency.messaging concurrency.mailboxes locals kernel
-threads sequences calendar ;
+threads sequences calendar accessors ;
 
 :: lock-test-0 ( -- )
     [let | v [ V{ } clone ]
@@ -174,7 +174,7 @@ threads sequences calendar ;
     ] ;
 
 [ lock-timeout-test ] [
-    linked-error-thread thread-name "Lock timeout-er" =
+    linked-error-thread name>> "Lock timeout-er" =
 ] must-fail-with
 
 :: read/write-test ( -- )

basis/concurrency/messaging/messaging.factor

@@ -4,14 +4,14 @@
 ! 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 -- )
 
 : mailbox-of ( thread -- mailbox )
-    dup thread-mailbox [ ] [
+    dup mailbox>> [ ] [
-        <mailbox> dup rot set-thread-mailbox
+        <mailbox> [ >>mailbox drop ] keep
     ] ?if ;
 
 M: thread 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/cpu/x86/64/64.factor

@@ -3,7 +3,7 @@
 USING: accessors alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture kernel kernel.private math
-namespaces sequences compiler.generator.registers
+namespaces sequences compiler.generator compiler.generator.registers
 compiler.generator.fixup system layouts alien alien.accessors
 alien.structs slots splitting assocs ;
 IN: cpu.x86.64

basis/cpu/x86/intrinsics/intrinsics.factor

@@ -404,10 +404,8 @@ IN: cpu.x86.intrinsics
 
 : %alien-integer-set ( quot reg -- )
     small-reg PUSH
-    "offset" get "value" get = [
-        "value" operand %untag-fixnum
-    ] unless
     small-reg "value" operand MOV
+    small-reg %untag-fixnum
     swap %alien-accessor
     small-reg POP ; inline
 

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/float-arrays/float-arrays.factor

@@ -58,8 +58,7 @@ INSTANCE: float-array sequence
 : 4float-array ( w x y z -- array )
     T{ float-array } 4sequence ; inline
 
-: F{ ( parsed -- parsed )
+: F{ \ } [ >float-array ] parse-literal ; parsing
-    \ } [ >float-array ] parse-literal ; parsing
 
 M: float-array pprint-delims drop \ F{ \ } ;
 

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/servers/connection/connection.factor

@@ -41,7 +41,7 @@ ready ;
 
 SYMBOL: remote-address
 
-GENERIC: handle-client* ( server -- )
+GENERIC: handle-client* ( threaded-server -- )
 
 <PRIVATE
 
@@ -75,21 +75,21 @@ M: threaded-server handle-client* handler>> call ;
 : thread-name ( server-name addrspec -- string )
     unparse " connection from " swap 3append ;
 
-: accept-connection ( server -- )
+: accept-connection ( threaded-server -- )
     [ accept ] [ addr>> ] bi
     [ '[ , , , handle-client ] ]
     [ drop threaded-server get name>> swap thread-name ] 2bi
     spawn drop ;
 
-: accept-loop ( server -- )
+: accept-loop ( threaded-server -- )
     [
         threaded-server get semaphore>>
         [ [ accept-connection ] with-semaphore ]
         [ accept-connection ]
         if*
-    ] [ accept-loop ] bi ; inline
+    ] [ accept-loop ] bi ; inline recursive
 
-: started-accept-loop ( server -- )
+: started-accept-loop ( threaded-server -- )
     threaded-server get
     [ sockets>> push ] [ ready>> raise-flag ] bi ;
 

basis/io/sockets/sockets-docs.factor

@@ -62,7 +62,7 @@ ARTICLE: "network-streams" "Networking"
 ABOUT: "network-streams"
 
 HELP: local
-{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $link local-path } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." }
+{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $snippet "path" } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." }
 { $examples
     { $code "\"/tmp/.X11-unix/0\" <local>" }
 } ;

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/persistent/heaps/heaps-docs.factor

@@ -38,7 +38,7 @@ HELP: pheap>alist
 { $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
 
 HELP: pheap>values
-{ $values { "heap" "a persistent heap" } { "values" array } }
+{ $values { "heap" "a persistent heap" } { "seq" array } }
 { $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
 
 ARTICLE: "persistent-heaps" "Persistent heaps"

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/stack-checker/inlining/inlining.factor

@@ -67,8 +67,10 @@ SYMBOL: enter-out
     [ entry-stack-height current-stack-height swap - ]
     bi*
     = [ 2drop ] [
-        word>> current-stack-height
+        terminated? get [ 2drop ] [
-        unbalanced-recursion-error inference-error
+            word>> current-stack-height
+            unbalanced-recursion-error inference-error
+        ] if
     ] if ;
 
 : end-recursive-word ( word label -- )
@@ -79,7 +81,7 @@ SYMBOL: enter-out
 : recursive-word-inputs ( label -- n )
     entry-stack-height d-in get + ;
 
-: (inline-recursive-word) ( word -- label in out visitor )
+: (inline-recursive-word) ( word -- label in out visitor terminated? )
     dup prepare-stack
     [
         init-inference
@@ -96,11 +98,13 @@ SYMBOL: enter-out
         dup recursive-word-inputs
         meta-d get
         stack-visitor get
+        terminated? get
     ] with-scope ;
 
 : inline-recursive-word ( word -- )
     (inline-recursive-word)
-    [ consume-d ] [ output-d ] [ ] tri* #recursive, ;
+    [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
+    [ terminate ] when ;
 
 : check-call-height ( label -- )
     dup entry-stack-height current-stack-height >

basis/stack-checker/known-words/known-words.factor

@@ -331,7 +331,7 @@ SYMBOL: +primitive+
 \ bignum-bitnot { bignum } { bignum } define-primitive
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } define-primitive
+\ bignum-shift { bignum fixnum } { bignum } define-primitive
 \ bignum-shift make-foldable
 
 \ bignum< { bignum bignum } { object } define-primitive

basis/stack-checker/stack-checker-tests.factor

@@ -575,3 +575,8 @@ DEFER: eee'
 : eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
 
 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
+
+: bogus-error ( x -- )
+    dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
+
+[ bogus-error ] must-infer

basis/state-parser/state-parser.factor

@@ -88,13 +88,12 @@ SYMBOL: prolog-data
 : next* ( -- )
     get-char [ (next) record ] when ;
 
-: skip-until ( quot -- )
+: skip-until ( quot: ( -- ? ) -- )
-    #! quot: ( -- ? )
     get-char [
         [ call ] keep swap [ drop ] [
             next skip-until
         ] if
-    ] [ drop ] if ; inline
+    ] [ drop ] if ; inline recursive
 
 : take-until ( quot -- string )
     #! Take the substring of a string starting at spot

basis/threads/threads-docs.factor

@@ -38,7 +38,7 @@ ARTICLE: "thread-state" "Thread-local state and variables"
 { $subsection tchange }
 "Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
 $nl
-"Global hashtable of all threads, keyed by " { $link thread-id } ":"
+"Global hashtable of all threads, keyed by " { $snippet "id" } ":"
 { $subsection threads }
 "Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
 
@@ -63,10 +63,10 @@ ABOUT: "threads"
 HELP: thread
 { $class-description "A thread. The slots are as follows:"
     { $list
-        { { $link thread-id } " - a unique identifier assigned to each thread." }
+        { { $snippet "id" } " - a unique identifier assigned to each thread." }
-        { { $link thread-name } " - the name passed to " { $link spawn } "." }
+        { { $snippet "name" } " - the name passed to " { $link spawn } "." }
-        { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." }
+        { { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." }
-        { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
+        { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
     }
 } ;
 

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,19 +2,19 @@
 ! 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 -- )
-    dup thread-id pprint-cell
+    dup id>> pprint-cell
-    dup thread-name over [ write-object ] with-cell
+    dup name>> over [ write-object ] with-cell
-    dup thread-state [
+    dup state>> [
         [ dup self eq? "running" "yield" ? ] unless*
         write
     ] with-cell
     [
-        thread-sleep-entry [
+        sleep-entry>> [
-            entry-key millis [-] number>string write
+            key>> millis [-] number>string write
             " ms" write
         ] when*
     ] with-cell ;

basis/tools/vocabs/vocabs.factor

@@ -4,7 +4,7 @@ USING: kernel io io.styles io.files io.encodings.utf8
 vocabs.loader vocabs sequences namespaces math.parser arrays
 hashtables assocs memoize summary sorting splitting combinators
 source-files debugger continuations compiler.errors init
-checksums checksums.crc32 sets ;
+checksums checksums.crc32 sets accessors ;
 IN: tools.vocabs
 
 : vocab-tests-file ( vocab -- path )
@@ -61,10 +61,10 @@ SYMBOL: failures
 
 : source-modified? ( path -- ? )
     dup source-files get at [
-        dup source-file-path
+        dup path>>
         dup exists? [
             utf8 file-lines crc32 checksum-lines
-            swap source-file-checksum = not
+            swap checksum>> = not
         ] [
             2drop f
         ] if
@@ -175,7 +175,7 @@ M: vocab summary
     [
         dup vocab-summary %
         " (" %
-        vocab-words assoc-size #
+        words>> assoc-size #
         " words)" %
     ] "" make ;
 

basis/tools/walker/debug/debug.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises models tools.walker kernel
 sequences concurrency.messaging locals continuations
-threads namespaces namespaces.private assocs ;
+threads namespaces namespaces.private assocs accessors ;
 IN: tools.walker.debug
 
 :: test-walker ( quot -- data )
@@ -26,6 +26,6 @@ IN: tools.walker.debug
         send-synchronous drop
 
         p ?promise
-        thread-variables walker-continuation swap at
+        variables>> walker-continuation swap at
-        model-value continuation-data
+        model-value data>>
     ] ;

basis/tools/walker/walker.factor

@@ -22,8 +22,8 @@ DEFER: start-walker-thread
 
 : get-walker-thread ( -- status continuation thread )
     walker-thread tget [
-        [ thread-variables walker-status swap at ]
+        [ variables>> walker-status swap at ]
-        [ thread-variables walker-continuation swap at ]
+        [ variables>> walker-continuation swap at ]
         [ ] tri
     ] [
         f <model>
@@ -43,7 +43,7 @@ DEFER: start-walker-thread
     } cond ;
 
 : break ( -- )
-    continuation callstack over set-continuation-call
+    continuation callstack >>call
     show-walker send-synchronous
     after-break ;
 
@@ -248,7 +248,7 @@ SYMBOL: +stopped+
 : associate-thread ( walker -- )
     walker-thread tset
     [ f walker-thread tget send-synchronous drop ]
-    self set-thread-exit-handler ;
+    self (>>exit-handler) ;
 
 : start-walker-thread ( status continuation -- thread' )
     self [
@@ -258,7 +258,7 @@ SYMBOL: +stopped+
         V{ } clone walker-history tset
         walker-loop
     ] 3curry
-    "Walker on " self thread-name append spawn
+    "Walker on " self name>> append spawn
     [ associate-thread ] keep ;
 
 ! For convenience

basis/unicode/case/case.factor

@@ -1,6 +1,6 @@
 USING: unicode.data sequences sequences.next namespaces
 unicode.normalize math unicode.categories combinators
-assocs strings splitting kernel ;
+assocs strings splitting kernel accessors ;
 IN: unicode.case
 
 : at-default ( key assoc -- value/key ) over >r at r> or ;
@@ -91,17 +91,17 @@ SYMBOL: locale ! Just casing locale, or overall?
 
 : >lower ( string -- lower )
     i-dot? [ turk>lower ] when
-    final-sigma [ code-point-lower ] [ ch>lower ] map-case ;
+    final-sigma [ lower>> ] [ ch>lower ] map-case ;
 
 : >upper ( string -- upper )
     i-dot? [ turk>upper ] when
-    [ code-point-upper ] [ ch>upper ] map-case ;
+    [ upper>> ] [ ch>upper ] map-case ;
 
 : >title ( string -- title )
     final-sigma
     CHAR: \s swap
     [ tuck word-boundary swapd
-        [ code-point-title ] [ code-point-lower ] if ]
+        [ title>> ] [ lower>> ] if ]
     [ tuck word-boundary swapd 
         [ ch>title ] [ ch>lower ] if ]
     map-case nip ;

basis/unicode/normalize/normalize.factor

@@ -1,5 +1,5 @@
 USING: sequences namespaces unicode.data kernel math arrays
-locals sorting.insertion ;
+locals sorting.insertion accessors ;
 IN: unicode.normalize
 
 ! Conjoining Jamo behavior
@@ -43,7 +43,7 @@ IN: unicode.normalize
 : reorder-next ( string i -- new-i done? )
     over [ non-starter? ] find-from drop [
         reorder-slice
-        >r dup [ combining-class ] insertion-sort slice-to r>
+        >r dup [ combining-class ] insertion-sort to>> r>
     ] [ length t ] if* ;
 
 : reorder-loop ( string start -- )

basis/xml-rpc/xml-rpc.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel xml arrays math generic http.client combinators
+USING: accessors kernel xml arrays math generic http.client
-    hashtables namespaces io base64 sequences strings calendar
+combinators hashtables namespaces io base64 sequences strings
-    xml.data xml.writer xml.utilities assocs math.parser debugger
+calendar xml.data xml.writer xml.utilities assocs math.parser
-    calendar.format math.order ;
+debugger calendar.format math.order ;
 IN: xml-rpc
 
 ! * Sending RPC requests
@@ -17,7 +17,7 @@ M: integer item>xml
     [ "Integers must fit in 32 bits" throw ] unless
     number>string "i4" build-tag ;
 
-PREDICATE: boolean < object { t f } member? ;
+UNION: boolean t POSTPONE: f ;
 
 M: boolean item>xml
     "1" "0" ? "boolean" build-tag ;
@@ -147,10 +147,10 @@ TAG: array xml>item
     xml>item [ "faultCode" get "faultString" get ] bind ;
 
 : receive-rpc ( xml -- rpc )
-    dup name-tag dup "methodCall" =
+    dup main>> dup "methodCall" =
     [ drop parse-method <rpc-method> ] [
         "methodResponse" = [
-            dup first-child-tag name-tag "fault" =
+            dup first-child-tag main>> "fault" =
             [ parse-fault <rpc-fault> ]
             [ parse-rpc-response <rpc-response> ] if
         ] [ "Bad main tag name" server-error ] if

basis/xml/data/data.factor

@@ -1,25 +1,26 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private assocs arrays
-delegate.protocols delegate vectors ;
+delegate.protocols delegate vectors accessors multiline
+macros words quotations combinators ;
 IN: xml.data
 
-TUPLE: name space tag url ;
+TUPLE: name space main url ;
 C: <name> name
 
 : ?= ( object/f object/f -- ? )
     2dup and [ = ] [ 2drop t ] if ;
 
 : names-match? ( name1 name2 -- ? )
-    [ name-space swap name-space ?= ] 2keep
+    [ [ space>> ] bi@ ?= ]
-    [ name-url swap name-url ?= ] 2keep
+    [ [ url>> ] bi@ ?= ]
-    name-tag swap name-tag ?= and and ;
+    [ [ main>> ] bi@ ?= ] 2tri and and ;
 
-: <name-tag> ( string -- name )
+: <simple-name> ( string -- name )
     f swap f <name> ;
 
 : assure-name ( string/name -- name )
-    dup name? [ <name-tag> ] unless ;
+    dup name? [ <simple-name> ] unless ;
 
 TUPLE: opener name attrs ;
 C: <opener> opener
@@ -42,13 +43,11 @@ C: <instruction> instruction
 TUPLE: prolog version encoding standalone ;
 C: <prolog> prolog
 
-TUPLE: tag attrs children ;
-
 TUPLE: attrs alist ;
 C: <attrs> attrs
 
 : attr@ ( key alist -- index {key,value} )
-    >r assure-name r> attrs-alist
+    >r assure-name r> alist>>
     [ first names-match? ] with find ;
 
 M: attrs at*
@@ -58,12 +57,12 @@ M: attrs set-at
         2nip set-second
     ] [
         >r assure-name swap 2array r>
-        [ attrs-alist ?push ] keep set-attrs-alist
+        [ alist>> ?push ] keep (>>alist)
     ] if* ;
 
-M: attrs assoc-size attrs-alist length ;
+M: attrs assoc-size alist>> length ;
 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
-M: attrs >alist attrs-alist ;
+M: attrs >alist alist>> ;
 
 : >attrs ( assoc -- attrs )
     dup [
@@ -74,61 +73,71 @@ M: attrs assoc-like
     drop dup attrs? [ >attrs ] unless ;
 
 M: attrs clear-assoc
-    f swap set-attrs-alist ;
+    f >>alist drop ;
 M: attrs delete-at
-    tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
+    tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
 
 M: attrs clone
-    attrs-alist clone <attrs> ;
+    alist>> clone <attrs> ;
 
 INSTANCE: attrs assoc
 
+TUPLE: tag name attrs children ;
+
 : <tag> ( name attrs children -- tag )
-    >r >r assure-name r> T{ attrs } assoc-like r>
+    [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
-    { set-delegate set-tag-attrs set-tag-children }
+    tag boa ;
-    tag construct ;
 
 ! For convenience, tags follow the assoc protocol too (for attrs)
 CONSULT: assoc-protocol tag tag-attrs ;
 INSTANCE: tag assoc
 
 ! They also follow the sequence protocol (for children)
-CONSULT: sequence-protocol tag tag-children ;
+CONSULT: sequence-protocol tag children>> ;
 INSTANCE: tag sequence
 
+CONSULT: name tag name>> ;
+
 M: tag like
     over tag? [ drop ] [
-        [ delegate ] keep tag-attrs
+        [ name>> ] keep tag-attrs
         rot dup [ V{ } like ] when <tag>
     ] if ;
 
+MACRO: clone-slots ( class -- tuple )
+    [
+        "slots" word-prop
+        [ reader>> 1quotation [ clone ] compose ] map
+        [ cleave ] curry
+    ] [ [ boa ] curry ] bi compose ;
+
 M: tag clone
-    [ delegate clone ] keep [ tag-attrs clone ] keep
+    tag clone-slots ;
-    tag-children clone
-    { set-delegate set-tag-attrs set-tag-children } tag construct ;
 
-TUPLE: xml prolog before main after ;
+TUPLE: xml prolog before body after ;
-: <xml> ( prolog before main after -- xml )
+C: <xml> xml
-    { set-xml-prolog set-xml-before set-delegate set-xml-after }
-    xml construct ;
 
-CONSULT: sequence-protocol xml delegate ;
+CONSULT: sequence-protocol xml body>> ;
 INSTANCE: xml sequence
 
-CONSULT: assoc-protocol xml delegate ;
+CONSULT: assoc-protocol xml body>> ;
 INSTANCE: xml assoc
 
+CONSULT: tag xml body>> ;
+
+CONSULT: name xml body>> ;
+
 <PRIVATE
 : tag>xml ( xml tag -- newxml )
-    swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
+    >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
+    swap <xml> ;
 
 : seq>xml ( xml seq -- newxml )
-    over delegate like tag>xml ;
+    over body>> like tag>xml ;
 PRIVATE>
 
 M: xml clone
-    [ xml-prolog clone ] keep [ xml-before clone ] keep
+   xml clone-slots ;
-    [ delegate clone ] keep xml-after clone <xml> ;
 
 M: xml like
     swap dup xml? [ nip ] [
@@ -139,5 +148,5 @@ M: xml like
 : <contained-tag> ( name attrs -- tag )
     f <tag> ;
 
-PREDICATE: contained-tag < tag tag-children not ;
+PREDICATE: contained-tag < tag children>> not ;
-PREDICATE: open-tag < tag tag-children ;
+PREDICATE: open-tag < tag children>> ;

basis/xml/generator/generator.factor

@@ -27,7 +27,7 @@ IN: xml.generator
 
 ! Word-based XML literal syntax
 : parsed-name ( accum -- accum )
-    scan ":" split1 [ f <name> ] [ <name-tag> ] if* parsed ;
+    scan ":" split1 [ f <name> ] [ <simple-name> ] if* parsed ;
 
 : run-combinator ( accum quot1 quot2 -- accum )
     >r [ ] like parsed r> [ parsed ] each ;

basis/xml/tests/templating.factor

@@ -1,5 +1,5 @@
 USING: kernel xml sequences assocs tools.test io arrays namespaces
-    xml.data xml.utilities xml.writer generic sequences.deep ;
+accessors xml.data xml.utilities xml.writer generic sequences.deep ;
 IN: xml.tests
 
 : sub-tag
@@ -11,7 +11,7 @@ GENERIC: (r-ref) ( xml -- )
 M: tag (r-ref)
     sub-tag over at* [
         ref-table get at
-        swap set-tag-children
+        >>children drop
     ] [ 2drop ] if ;
 M: object (r-ref) drop ;
 
@@ -34,7 +34,7 @@ M: object (r-ref) drop ;
     [
         H{
             { "foo" { "foo" } }
-            { "bar" { "blah" T{ tag T{ name f "" "a" "" } V{ } f } } }
+            { "bar" { "blah" T{ tag f T{ name f "" "a" "" } f f } } }
             { "baz" f }
         } ref-table set
         sample-doc string>xml dup template xml>string

basis/xml/tests/test.factor

@@ -3,7 +3,7 @@
 IN: xml.tests
 USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
     parser strings xml.data io.files xml.writer xml.utilities state-parser 
-    continuations assocs sequences.deep ;
+    continuations assocs sequences.deep accessors ;
 
 ! This is insufficient
 \ read-xml must-infer
@@ -11,22 +11,22 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
 SYMBOL: xml-file
 [ ] [ "resource:basis/xml/tests/test.xml"
     [ file>xml ] with-html-entities xml-file set ] unit-test
-[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
+[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
-[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
+[ f ] [ xml-file get prolog>> standalone>> ] unit-test
-[ "a" ] [ xml-file get name-space ] unit-test
+[ "a" ] [ xml-file get space>> ] unit-test
-[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test
+[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
 [ "that" ] [
     xml-file get T{ name f "" "this" "http://d.de" } swap at
 ] unit-test
-[ t ] [ xml-file get tag-children second contained-tag? ] unit-test
+[ t ] [ xml-file get children>> second contained-tag? ] unit-test
 [ "<a></b>" string>xml ] [ xml-parse-error? ] must-fail-with
 [ T{ comment f "This is where the fun begins!" } ] [
     xml-file get xml-before [ comment? ] find nip
 ] unit-test
 [ "xsl stylesheet=\"that-one.xsl\"" ] [
-    xml-file get xml-after [ instruction? ] find nip instruction-text
+    xml-file get after>> [ instruction? ] find nip text>>
 ] unit-test
-[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
+[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
 [ "that" ] [ xml-file get "this" swap at ] unit-test
 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
     [ "<a b='c'/>" string>xml xml>string ] unit-test

basis/xml/tokenize/tokenize.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: xml.errors xml.data xml.utilities xml.char-classes sets
 xml.entities kernel state-parser kernel namespaces strings math
-math.parser sequences assocs arrays splitting combinators unicode.case ;
+math.parser sequences assocs arrays splitting combinators unicode.case
+accessors ;
 IN: xml.tokenize
 
 ! XML namespace processing: ns = namespace
@@ -14,8 +15,8 @@ SYMBOL: ns-stack
     ! this should check to make sure URIs are valid
     [
         [
-            swap dup name-space "xmlns" =
+            swap dup space>> "xmlns" =
-            [ name-tag set ]
+            [ main>> set ]
             [
                 T{ name f "" "xmlns" f } names-match?
                 [ "" set ] [ drop ] if
@@ -24,8 +25,8 @@ SYMBOL: ns-stack
     ] { } make-assoc f like ;
 
 : add-ns ( name -- )
-    dup name-space dup ns-stack get assoc-stack
+    dup space>> dup ns-stack get assoc-stack
-    [ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
+    [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
 
 : push-ns ( hash -- )
     ns-stack get push ;

basis/xml/utilities/utilities.factor

@@ -10,13 +10,13 @@ IN: xml.utilities
 TUPLE: process-missing process tag ;
 M: process-missing error.
     "Tag <" write
-    dup process-missing-tag print-name
+    dup tag>> print-name
     "> not implemented on process process " write
-    process-missing-process name>> print ;
+    name>> print ;
 
 : run-process ( tag word -- )
     2dup "xtable" word-prop
-    >r dup name-tag r> at* [ 2nip call ] [
+    >r dup main>> r> at* [ 2nip call ] [
         drop \ process-missing boa throw
     ] if ;
 
@@ -48,17 +48,18 @@ M: process-missing error.
     standard-prolog { } rot { } <xml> ;
 
 : children>string ( tag -- string )
-    tag-children {
+    children>> {
         { [ dup empty? ] [ drop "" ] }
-        { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
+        { [ dup [ string? not ] contains? ]
+          [ "XML tag unexpectedly contains non-text children" throw ] }
         [ concat ]
     } cond ;
 
 : children-tags ( tag -- sequence )
-    tag-children [ tag? ] filter ;
+    children>> [ tag? ] filter ;
 
 : first-child-tag ( tag -- tag )
-    tag-children [ tag? ] find nip ;
+    children>> [ tag? ] find nip ;
 
 ! * Accessing part of an XML document
 ! for tag- words, a start means that it searches all children
@@ -91,7 +92,7 @@ M: process-missing error.
     assure-name [ tag-with-attr? ] 2curry find nip ;
 
 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ [ tag-with-attr? ] 2curry filter tag-children ;
+    tags@ [ tag-with-attr? ] 2curry filter children>> ;
 
 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
     assure-name [ tag-with-attr? ] 2curry deep-find ;
@@ -109,8 +110,8 @@ M: process-missing error.
     names-match? [ "Unexpected XML tag found" throw ] unless ;
 
 : insert-children ( children tag -- )
-    dup tag-children [ push-all ]
+    dup children>> [ push-all ]
-    [ >r V{ } like r> set-tag-children ] if ;
+    [ swap V{ } like >>children drop ] if ;
 
 : insert-child ( child tag -- )
     >r 1vector r> insert-children ;

basis/xml/writer/writer.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables kernel math namespaces sequences strings
-assocs combinators io io.streams.string
+assocs combinators io io.streams.string accessors
 xml.data wrap xml.entities unicode.categories ;
 IN: xml.writer
 
@@ -38,9 +38,9 @@ SYMBOL: indenter
     ] when ;
 
 : print-name ( name -- )
-    dup name-space f like
+    dup space>> f like
     [ write CHAR: : write1 ] when*
-    name-tag write ;
+    main>> write ;
 
 : print-attrs ( assoc -- )
     [
@@ -59,7 +59,7 @@ M: string write-item
 
 : write-tag ( tag -- )
     ?indent CHAR: < write1
-    dup print-name tag-attrs print-attrs ;
+    dup print-name attrs>> print-attrs ;
 
 : write-start-tag ( tag -- )
     write-tag ">" write ;
@@ -68,7 +68,7 @@ M: contained-tag write-item
     write-tag "/>" write ;
 
 : write-children ( tag -- )
-    indent tag-children ?filter-children
+    indent children>> ?filter-children
     [ write-item ] each unindent ;
 
 : write-end-tag ( tag -- )
@@ -85,18 +85,18 @@ M: open-tag write-item
     r> xml-pprint? set ;
 
 M: comment write-item
-    "<!--" write comment-text write "-->" write ;
+    "<!--" write text>> write "-->" write ;
 
 M: directive write-item
-    "<!" write directive-text write CHAR: > write1 ;
+    "<!" write text>> write CHAR: > write1 ;
 
 M: instruction write-item
-    "<?" write instruction-text write "?>" write ;
+    "<?" write text>> write "?>" write ;
 
 : write-prolog ( xml -- )
-    "<?xml version=\"" write dup prolog-version write
+    "<?xml version=\"" write dup version>> write
-    "\" encoding=\"" write dup prolog-encoding write
+    "\" encoding=\"" write dup encoding>> write
-    prolog-standalone [ "\" standalone=\"yes" write ] when
+    standalone>> [ "\" standalone=\"yes" write ] when
     "\"?>" write ;
 
 : write-chunk ( seq -- )
@@ -104,10 +104,10 @@ M: instruction write-item
 
 : write-xml ( xml -- )
     {
-        [ xml-prolog write-prolog ]
+        [ prolog>> write-prolog ]
-        [ xml-before write-chunk ]
+        [ before>> write-chunk ]
-        [ write-item ]
+        [ body>> write-item ]
-        [ xml-after write-chunk ]
+        [ after>> write-chunk ]
     } cleave ;
 
 : print-xml ( xml -- )

basis/xml/xml.factor

@@ -38,19 +38,19 @@ M: directive process
     add-child ;
 
 M: contained process
-    [ contained-name ] keep contained-attrs 
+    [ name>> ] [ attrs>> ] bi
     <contained-tag> add-child ;
 
 M: opener process push-xml ;
 
 : check-closer ( name opener -- name opener )
     dup [ <unopened> throw ] unless
-    2dup opener-name =
+    2dup name>> =
-    [ opener-name swap <mismatched> throw ] unless ;
+    [ name>> swap <mismatched> throw ] unless ;
 
 M: closer process
-    closer-name pop-xml first2
+    name>> pop-xml first2
-    >r check-closer opener-attrs r>
+    >r check-closer attrs>> r>
     <tag> add-child ;
 
 : init-xml-stack ( -- )
@@ -102,10 +102,10 @@ TUPLE: pull-xml scope ;
         init-parser reset-prolog init-ns-stack
         text-now? on
     ] H{ } make-assoc
-    { set-pull-xml-scope } pull-xml construct ;
+    pull-xml boa ;
 
 : pull-event ( pull -- xml-event/f )
-    pull-xml-scope [
+    scope>> [
         text-now? get [ parse-text f ] [
             get-char [ make-tag t ] [ f f ] if
         ] if text-now? set
@@ -127,17 +127,17 @@ TUPLE: pull-xml scope ;
 : call-under ( quot object -- quot )
     swap dup slip ; inline
 
-: sax-loop ( quot -- ) ! quot: xml-elem --
+: sax-loop ( quot: ( xml-elem -- ) -- )
     parse-text call-under
     get-char [ make-tag call-under sax-loop ]
-    [ drop ] if ; inline
+    [ drop ] if ; inline recursive
 
-: sax ( stream quot -- ) ! quot: xml-elem --
+: sax ( stream quot: ( xml-elem -- ) -- )
     swap [
         reset-prolog init-ns-stack
         prolog-data get call-under
         sax-loop
-    ] state-parse ; inline
+    ] state-parse ; inline recursive
 
 : (read-xml) ( -- )
     [ process ] sax-loop ; inline

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/classes/mixin/mixin-tests.factor

@@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 [ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
 
 [ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
+
+MIXIN: empty-mixin
+
+[ f ] [ "hi" empty-mixin? ] unit-test

core/classes/mixin/mixin.factor

@@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ;
     dup mixin-class? [
         drop
     ] [
-        { } redefine-mixin-class
+        [ { } redefine-mixin-class ]
+        [ update-classes ]
+        bi
     ] if ;
 
 TUPLE: check-mixin-class mixin ;

core/classes/tuple/tuple.factor

@@ -270,6 +270,9 @@ M: tuple-class define-tuple-class
         tri* define-declared
     ] 3tri ;
 
+M: tuple-class update-generic
+    over new-class? [ 2drop ] [ call-next-method ] if ;
+
 M: tuple-class reset-class
     [
         dup "slots" word-prop [

core/generic/generic.factor

@@ -62,7 +62,9 @@ TUPLE: check-method class generic ;
     [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
     values ;
 
-: update-generic ( class generic -- )
+GENERIC# update-generic 1 ( class generic -- )
+
+M: class update-generic
     affected-methods [ +called+ changed-definition ] each ;
 
 : with-methods ( class generic quot -- )

core/io/binary/binary-tests.factor

@@ -2,7 +2,9 @@ USING: io.binary tools.test classes math ;
 IN: io.binary.tests
 
 [ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
+[ B{ 0 0 0 0 0 0 4 HEX: d2 } ] [ 1234 8 >be ] unit-test
 [ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
+[ B{ HEX: d2 4 0 0 0 0 0 0 } ] [ 1234 8 >le ] unit-test
 
 [ 1234 ] [ 1234 4 >be be> ] unit-test
 [ 1234 ] [ 1234 4 >le le> ] unit-test

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/parser/parser.factor

@@ -24,7 +24,7 @@ t parser-notes set-global
 
 : note. ( str -- )
     parser-notes? [
-        file get [ path>> write ] when*
+        file get [ path>> write ":" write ] when* 
         lexer get line>> number>string write ": " write
         "Note: " write dup print
     ] when drop ;
@@ -216,7 +216,7 @@ SYMBOL: interactive-vocabs
 : filter-moved ( assoc1 assoc2 -- seq )
     swap assoc-diff [
         drop where dup [ first ] when
-        file get source-file-path =
+        file get path>> =
     ] assoc-filter keys ;
 
 : removed-definitions ( -- assoc1 assoc2 )

core/sequences/sequences-docs.factor

@@ -779,19 +779,19 @@ HELP: collapse-slice
 
 HELP: <flat-slice>
 { $values { "seq" sequence } { "slice" slice } }
-{ $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $link slice-from } " equal to 0 and " { $link slice-to } " equal to the length of " { $snippet "seq" } "." }
+{ $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $snippet "from" } " equal to 0 and " { $snippet "to" } " equal to the length of " { $snippet "seq" } "." }
 { $notes "Some words create slices then proceed to read the " { $snippet "to" } " and " { $snippet "from" } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ;
 
 HELP: <slice>
 { $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" slice } }
 { $description "Outputs a new virtual sequence sharing storage with the subrange of elements in " { $snippet "seq" } " with indices starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
 { $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." }
-{ $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $link slice-from } " and " { $link slice-to } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ;
+{ $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $snippet "from" } " and " { $snippet "to" } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ;
 
 { <slice> subseq } related-words
 
 HELP: repetition
-{ $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
+{ $class-description "A virtual sequence consisting of " { $snippet "elt" } " repeated " { $snippet "len" } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
 
 HELP: <repetition> ( len elt -- repetition )
 { $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } }

core/slots/deprecated/deprecated.factor

@@ -6,15 +6,15 @@ classes slots.private combinators slots ;
 IN: slots.deprecated
 
 : reader-effect ( class spec -- effect )
-    >r ?word-name 1array r> slot-spec-name 1array <effect> ;
+    >r ?word-name 1array r> name>> 1array <effect> ;
 
 PREDICATE: slot-reader < word "reading" word-prop >boolean ;
 
 : set-reader-props ( class spec -- )
     2dup reader-effect
-    over slot-spec-reader
+    over reader>>
     swap "declared-effect" set-word-prop
-    slot-spec-reader swap "reading" set-word-prop ;
+    reader>> swap "reading" set-word-prop ;
 
 : define-slot-word ( class word quot -- )
     [
@@ -23,9 +23,9 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ;
     ] dip define ;
 
 : define-reader ( class spec -- )
-    dup slot-spec-reader [
+    dup reader>> [
         [ set-reader-props ] 2keep
-        dup slot-spec-reader
+        dup reader>>
         swap reader-quot
         define-slot-word
     ] [
@@ -33,20 +33,20 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ;
     ] if ;
 
 : writer-effect ( class spec -- effect )
-    slot-spec-name swap ?word-name 2array 0 <effect> ;
+    name>> swap ?word-name 2array 0 <effect> ;
 
 PREDICATE: slot-writer < word "writing" word-prop >boolean ;
 
 : set-writer-props ( class spec -- )
     2dup writer-effect
-    over slot-spec-writer
+    over writer>>
     swap "declared-effect" set-word-prop
-    slot-spec-writer swap "writing" set-word-prop ;
+    writer>> swap "writing" set-word-prop ;
 
 : define-writer ( class spec -- )
-    dup slot-spec-writer [
+    dup writer>> [
         [ set-writer-props ] 2keep
-        dup slot-spec-writer
+        dup writer>>
         swap writer-quot
         define-slot-word
     ] [