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

basis/alias/alias-docs.factor

@@ -6,8 +6,10 @@ HELP: ALIAS:
 { $values { "new-word" word } { "existing-word" word } }
 { $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
 { $examples
-    { $example "ALIAS: sequence-nth nth"
+    { $example "USING: alias prettyprint sequences ;"
-               "0 { 10 20 30 } sequence-nth"
+               "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/arrays/arrays.factor

@@ -10,7 +10,7 @@ M: array c-type ;
 
 M: array heap-size unclip heap-size [ * ] reduce ;
 
-M: array c-type-align first c-type c-type-align ;
+M: array c-type-align first c-type-align ;
 
 M: array c-type-stack-align? drop f ;
 

basis/alien/c-types/c-types.factor

@@ -37,6 +37,7 @@ ERROR: no-c-type name ;
         dup string? [ (c-type) ] when
     ] when ;
 
+! C type protocol
 GENERIC: c-type ( name -- type ) foldable
 
 : resolve-pointer-type ( name -- name )
@@ -62,6 +63,60 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+GENERIC: c-type-boxer ( name -- boxer )
+
+M: c-type c-type-boxer boxer>> ;
+
+M: string c-type-boxer c-type c-type-boxer ;
+
+GENERIC: c-type-boxer-quot ( name -- quot )
+
+M: c-type c-type-boxer-quot boxer-quot>> ;
+
+M: string c-type-boxer-quot c-type c-type-boxer-quot ;
+
+GENERIC: c-type-unboxer ( name -- boxer )
+
+M: c-type c-type-unboxer unboxer>> ;
+
+M: string c-type-unboxer c-type c-type-unboxer ;
+
+GENERIC: c-type-unboxer-quot ( name -- quot )
+
+M: c-type c-type-unboxer-quot unboxer-quot>> ;
+
+M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
+
+GENERIC: c-type-reg-class ( name -- reg-class )
+
+M: c-type c-type-reg-class reg-class>> ;
+
+M: string c-type-reg-class c-type c-type-reg-class ;
+
+GENERIC: c-type-getter ( name -- quot )
+
+M: c-type c-type-getter getter>> ;
+
+M: string c-type-getter c-type c-type-getter ;
+
+GENERIC: c-type-setter ( name -- quot )
+
+M: c-type c-type-setter setter>> ;
+
+M: string c-type-setter c-type c-type-setter ;
+
+GENERIC: c-type-align ( name -- n )
+
+M: c-type c-type-align align>> ;
+
+M: string c-type-align c-type c-type-align ;
+
+GENERIC: c-type-stack-align? ( name -- ? )
+
+M: c-type c-type-stack-align? stack-align?>> ;
+
+M: string c-type-stack-align? c-type c-type-stack-align? ;
+
 : c-type-box ( n type -- )
     dup c-type-reg-class
     swap c-type-boxer [ "No boxer" throw ] unless*
@@ -72,10 +127,6 @@ M: string c-type ( name -- type )
     swap c-type-unboxer [ "No unboxer" throw ] unless*
     %unbox ;
 
-M: string c-type-align c-type c-type-align ;
-
-M: string c-type-stack-align? c-type c-type-stack-align? ;
-
 GENERIC: box-parameter ( n ctype -- )
 
 M: c-type box-parameter c-type-box ;
@@ -107,25 +158,25 @@ GENERIC: heap-size ( type -- size ) foldable
 
 M: string heap-size c-type heap-size ;
 
-M: c-type heap-size c-type-size ;
+M: c-type heap-size size>> ;
 
 GENERIC: stack-size ( type -- size ) foldable
 
 M: string stack-size c-type stack-size ;
 
-M: c-type stack-size c-type-size ;
+M: c-type stack-size size>> ;
 
 GENERIC: byte-length ( seq -- n ) flushable
 
 M: byte-array byte-length length ;
 
 : c-getter ( name -- quot )
-    c-type c-type-getter [
+    c-type-getter [
         [ "Cannot read struct fields with type" throw ]
     ] unless* ;
 
 : c-setter ( name -- quot )
-    c-type c-type-setter [
+    c-type-setter [
         [ "Cannot write struct fields with type" throw ]
     ] unless* ;
 

basis/alien/structs/structs-docs.factor

@@ -1,13 +1,13 @@
 IN: alien.structs
-USING: alien.c-types strings help.markup help.syntax
+USING: accessors 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>
@@ -67,7 +67,7 @@ M: word slot-specs "slots" word-prop ;
     first dup "writing" word-prop [ slot-specs ] keep
     $spec-writer ;
 
-M: string slot-specs c-type struct-type-fields ;
+M: string slot-specs c-type fields>> ;
 
 M: array ($instance) first ($instance) " array" write ;
 

basis/alien/structs/structs-tests.factor

@@ -7,7 +7,7 @@ C-STRUCT: bar
     { { "int" 8 } "y" } ;
 
 [ 36 ] [ "bar" heap-size ] unit-test
-[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
+[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
 
 C-STRUCT: align-test
     { "int" "x" }

basis/alien/structs/structs.factor

@@ -6,32 +6,32 @@ slots.deprecated alien.c-types cpu.architecture ;
 IN: alien.structs
 
 : align-offset ( offset type -- offset )
-    c-type c-type-align align ;
+    c-type-align align ;
 
 : 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
+        [ c-getter ] [ c-type-boxer-quot ] bi append
     ] tri
     define-struct-slot-word ;
 
 : define-setter ( type spec -- )
     [ set-writer-props ] keep
     [ ]
-    [ slot-spec-writer ]
+    [ writer>> ]
     [ class>> c-setter ] tri
     define-struct-slot-word ;
 
@@ -44,9 +44,9 @@ IN: alien.structs
 
 TUPLE: struct-type size align fields ;
 
-M: struct-type heap-size struct-type-size ;
+M: struct-type heap-size size>> ;
 
-M: struct-type c-type-align struct-type-align ;
+M: struct-type c-type-align align>> ;
 
 M: struct-type c-type-stack-align? drop f ;
 

basis/bootstrap/stage2.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors init command-line namespaces words debugger io
+USING: accessors init namespaces words io
 kernel.private math memory continuations kernel io.files
 io.backend system parser vocabs sequences prettyprint
 vocabs.loader combinators splitting source-files strings
 definitions assocs compiler.errors compiler.units
-math.parser generic sets ;
+math.parser generic sets debugger command-line ;
 IN: bootstrap.stage2
 
 SYMBOL: bootstrap-time

basis/calendar/calendar-docs.factor

@@ -28,4 +28,103 @@ HELP: <date>
 
 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." } ;
+{ $description "Returns an array with the English names of all the months." }
+{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
+
+HELP: month-name
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the month name and returns it as a string.  January has an index of 1 instead of zero." } ;
+
+HELP: month-abbreviations
+{ $values { "array" array } }
+{ $description "Returns an array with the English abbreviated names of all the months." }
+{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
+
+HELP: month-abbreviation
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the abbreviated month name and returns it as a string.  January has an index of 1 instead of zero." } ;
+
+
+HELP: day-names
+{ $values { "array" array } }
+{ $description "Returns an array with the English names of the days of the week." } ;
+
+HELP: day-name
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the day name and returns it as a string." } ;
+
+HELP: day-abbreviations2
+{ $values { "array" array } }
+{ $description "Returns an array with the abbreviated English names of the days of the week.  This abbreviation is two characters long." } ;
+
+HELP: day-abbreviation2
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
+
+HELP: day-abbreviations3
+{ $values { "array" array } }
+{ $description "Returns an array with the abbreviated English names of the days of the week.  This abbreviation is three characters long." } ;
+
+HELP: day-abbreviation3
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is three characters long." } ;
+
+{
+    day-name day-names
+    day-abbreviation2 day-abbreviations2
+    day-abbreviation3 day-abbreviations3
+} related-words
+
+HELP: average-month
+{ $values { "ratio" ratio } }
+{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
+
+HELP: months-per-year
+{ $values { "integer" integer } }
+{ $description "Returns the number of months in a year." } ;
+
+HELP: days-per-year
+{ $values { "ratio" ratio } }
+{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
+
+HELP: hours-per-year
+{ $values { "ratio" ratio } }
+{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
+
+HELP: minutes-per-year
+{ $values { "ratio" ratio } }
+{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
+
+HELP: seconds-per-year
+{ $values { "integer" integer } }
+{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
+
+HELP: julian-day-number
+{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
+{ $description "Calculates the Julian day number from a year, month, and day.  The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
+{ $warning "Not valid before year -4800 BCE." } ;
+
+HELP: julian-day-number>date
+{ $values { "n" integer } { "year" integer } { "month" integer } { "day" integer } }
+{ $description "Converts from a Julian day number back to a year, month, and day." } ;
+{ julian-day-number julian-day-number>date } related-words
+
+HELP: >date<
+{ $values { "timestamp" timestamp } { "year" integer } { "month" integer } { "day" integer } }
+{ $description "Explodes a " { $snippet "timestamp" } " into its year, month, and day components." }
+{ $examples { $example "USING: arrays calendar prettyprint ;"
+                       "2010 8 24 <date> >date< 3array ."
+                       "{ 2010 8 24 }"
+                       }
+} ;
+
+HELP: >time<
+{ $values { "timestamp" timestamp } { "hour" integer } { "minute" integer } { "second" integer } }
+{ $description "Explodes a " { $snippet "timestamp" } " into its hour, minute, and second components." }
+{ $examples { $example "USING: arrays calendar prettyprint ;"
+                       "now noon >time< 3array ."
+                       "{ 12 0 0 }"
+                       }
+} ;
+
+{ >date< >time< } related-words

basis/calendar/calendar.factor

@@ -57,7 +57,7 @@ PRIVATE>
         "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
     } ;
 
-: month-abbreviation ( n -- array )
+: month-abbreviation ( n -- string )
     check-month 1- month-abbreviations nth ;
 
 : day-names ( -- array )
@@ -377,23 +377,24 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : friday ( timestamp -- timestamp ) 5 day-this-week ;
 : saturday ( timestamp -- timestamp ) 6 day-this-week ;
 
-: beginning-of-day ( timestamp -- new-timestamp )
+: midnight ( timestamp -- new-timestamp )
-    clone
+    clone 0 >>hour 0 >>minute 0 >>second ; inline
-    0 >>hour
+
-    0 >>minute
+: noon ( timestamp -- new-timestamp )
-    0 >>second ; inline
+    midnight 12 >>hour ; inline
 
 : beginning-of-month ( timestamp -- new-timestamp )
-    beginning-of-day 1 >>day ;
+    midnight 1 >>day ;
 
 : beginning-of-week ( timestamp -- new-timestamp )
-    beginning-of-day sunday ;
+    midnight sunday ;
 
 : beginning-of-year ( timestamp -- new-timestamp )
     beginning-of-month 1 >>month ;
 
 : time-since-midnight ( timestamp -- duration )
-    dup beginning-of-day time- ;
+    dup midnight time- ;
+
 
 M: timestamp sleep-until timestamp>millis sleep-until ;
 

basis/calendar/format/format.factor

@@ -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/channels/channels.factor

@@ -3,7 +3,7 @@
 !
 ! Channels - based on ideas from newsqueak
 USING: kernel sequences sequences.lib threads continuations
-random math ;
+random math accessors ;
 IN: channels
 
 TUPLE: channel receivers senders ;
@@ -17,14 +17,14 @@ GENERIC: from ( channel -- value )
 <PRIVATE
 
 : wait ( channel -- )
-    [ channel-senders push ] curry
+    [ senders>> push ] curry
     "channel send" suspend drop ;
 
 : (to) ( value receivers -- )
     delete-random resume-with yield ;
 
 : notify ( continuation channel -- channel )
-    [ channel-receivers push ] keep ;
+    [ receivers>> push ] keep ;
 
 : (from) ( senders -- )
     delete-random resume ;
@@ -32,11 +32,11 @@ GENERIC: from ( channel -- value )
 PRIVATE>
 
 M: channel to ( value channel -- )
-    dup channel-receivers
+    dup receivers>>
     dup empty? [ drop dup wait to ] [ nip (to) ] if ;
 
 M: channel from ( channel -- value )
     [
-        notify channel-senders
+        notify senders>>
         dup empty? [ drop ] [ (from) ] if
     ] curry "channel receive" suspend ;

basis/cocoa/views/views.factor

@@ -21,6 +21,10 @@ IN: cocoa.views
 : NSOpenGLPFASampleBuffers 55 ;
 : NSOpenGLPFASamples 56 ;
 : NSOpenGLPFAAuxDepthStencil 57 ;
+: NSOpenGLPFAColorFloat  58 ;
+: NSOpenGLPFAMultisample 59 ;
+: NSOpenGLPFASupersample 60 ;
+: NSOpenGLPFASampleAlpha 61 ;
 : NSOpenGLPFARendererID 70 ;
 : NSOpenGLPFASingleRenderer 71 ;
 : NSOpenGLPFANoRecovery 72 ;
@@ -34,25 +38,36 @@ IN: cocoa.views
 : NSOpenGLPFACompliant 83 ;
 : NSOpenGLPFAScreenMask 84 ;
 : NSOpenGLPFAPixelBuffer 90 ;
+: NSOpenGLPFAAllowOfflineRenderers 96 ;
 : NSOpenGLPFAVirtualScreenCount 128 ;
 
+: kCGLRendererGenericFloatID HEX: 00020400 ;
+
 <PRIVATE
 
 SYMBOL: +software-renderer+
+SYMBOL: +multisample+
 
 PRIVATE>
 
 : with-software-renderer ( quot -- )
-    t +software-renderer+ set
+    t +software-renderer+ pick with-variable ; inline
-    [ f +software-renderer+ set ]
+: with-multisample ( quot -- )
-    [ ] cleanup ; inline
+    t +multisample+ pick with-variable ; inline
 
 : <PixelFormat> ( -- pixelfmt )
     NSOpenGLPixelFormat -> alloc [
         NSOpenGLPFAWindow ,
         NSOpenGLPFADoubleBuffer ,
         NSOpenGLPFADepthSize , 16 ,
-        +software-renderer+ get [ NSOpenGLPFARobust , ] when
+        +software-renderer+ get [
+            NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
+        ] when
+        +multisample+ get [
+            NSOpenGLPFASupersample ,
+            NSOpenGLPFASampleBuffers , 1 ,
+            NSOpenGLPFASamples , 8 ,
+        ] when
         0 ,
     ] { } make >c-int-array
     -> initWithAttributes:

basis/compiler/compiler.factor

@@ -42,12 +42,17 @@ SYMBOL: +failed+
     [ compiled-unxref ]
     [
         dup crossref?
-        [ dependencies get compiled-xref ] [ drop ] if
+        [
+            dependencies get
+            generic-dependencies get
+            compiled-xref
+        ] [ drop ] if
     ] tri ;
 
 : (compile) ( word -- )
     '[
         H{ } clone dependencies set
+        H{ } clone generic-dependencies set
 
         , {
             [ compile-begins ]

basis/compiler/generator/registers/registers.factor

@@ -69,23 +69,21 @@ TUPLE: ds-loc n class ;
 
 : <ds-loc> ( n -- loc ) f ds-loc boa ;
 
-M: ds-loc minimal-ds-loc* ds-loc-n min ;
+M: ds-loc minimal-ds-loc* n>> min ;
-M: ds-loc operand-class* ds-loc-class ;
-M: ds-loc set-operand-class set-ds-loc-class ;
 M: ds-loc live-loc?
-    over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
+    over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
 
 ! A retain stack location.
 TUPLE: rs-loc n class ;
 
 : <rs-loc> ( n -- loc ) f rs-loc boa ;
-M: rs-loc operand-class* rs-loc-class ;
-M: rs-loc set-operand-class set-rs-loc-class ;
 M: rs-loc live-loc?
-    over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
+    over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
 
 UNION: loc ds-loc rs-loc ;
 
+M: loc operand-class* class>> ;
+M: loc set-operand-class (>>class) ;
 M: loc move-spec drop loc ;
 
 INSTANCE: loc value
@@ -106,12 +104,12 @@ M: cached set-operand-class vreg>> set-operand-class ;
 M: cached operand-class* vreg>> operand-class* ;
 M: cached move-spec drop cached ;
 M: cached live-vregs* vreg>> live-vregs* ;
-M: cached live-loc? cached-loc live-loc? ;
+M: cached live-loc? loc>> live-loc? ;
 M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
 M: cached lazy-store
-    2dup cached-loc live-loc?
+    2dup loc>> live-loc?
     [ "live-locs" get at %move ] [ 2drop ] if ;
-M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
+M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
 
 INSTANCE: cached value
 
@@ -121,48 +119,48 @@ TUPLE: tagged vreg class ;
 : <tagged> ( vreg -- tagged )
     f tagged boa ;
 
-M: tagged v>operand tagged-vreg v>operand ;
+M: tagged v>operand vreg>> v>operand ;
-M: tagged set-operand-class set-tagged-class ;
+M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* tagged-class ;
+M: tagged operand-class* class>> ;
 M: tagged move-spec drop f ;
-M: tagged live-vregs* tagged-vreg , ;
+M: tagged live-vregs* vreg>> , ;
 
 INSTANCE: tagged value
 
 ! Unboxed alien pointers
 TUPLE: unboxed-alien vreg ;
 C: <unboxed-alien> unboxed-alien
-M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+M: unboxed-alien v>operand vreg>> v>operand ;
 M: unboxed-alien operand-class* drop simple-alien ;
 M: unboxed-alien move-spec class ;
-M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+M: unboxed-alien live-vregs* vreg>> , ;
 
 INSTANCE: unboxed-alien value
 
 TUPLE: unboxed-byte-array vreg ;
 C: <unboxed-byte-array> unboxed-byte-array
-M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+M: unboxed-byte-array v>operand vreg>> v>operand ;
 M: unboxed-byte-array operand-class* drop c-ptr ;
 M: unboxed-byte-array move-spec class ;
-M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+M: unboxed-byte-array live-vregs* vreg>> , ;
 
 INSTANCE: unboxed-byte-array value
 
 TUPLE: unboxed-f vreg ;
 C: <unboxed-f> unboxed-f
-M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+M: unboxed-f v>operand vreg>> v>operand ;
 M: unboxed-f operand-class* drop \ f ;
 M: unboxed-f move-spec class ;
-M: unboxed-f live-vregs* unboxed-f-vreg , ;
+M: unboxed-f live-vregs* vreg>> , ;
 
 INSTANCE: unboxed-f value
 
 TUPLE: unboxed-c-ptr vreg ;
 C: <unboxed-c-ptr> unboxed-c-ptr
-M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+M: unboxed-c-ptr v>operand vreg>> v>operand ;
 M: unboxed-c-ptr operand-class* drop c-ptr ;
 M: unboxed-c-ptr move-spec class ;
-M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
+M: unboxed-c-ptr live-vregs* vreg>> , ;
 
 INSTANCE: unboxed-c-ptr value
 

basis/compiler/tests/folding.factor

@@ -0,0 +1,30 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel classes.mixin arrays ;
+IN: compiler.tests
+
+! Calls to generic words were not folded away.
+
+[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+    <"
+    USING: math arrays ;
+    IN: compiler.tests.folding
+    GENERIC: foldable-generic ( a -- b ) foldable
+    M: integer foldable-generic f <array> ;
+    "> eval
+] unit-test
+
+[ ] [
+    <"
+    USING: math arrays ;
+    IN: compiler.tests.folding
+    : fold-test ( -- x ) 10 foldable-generic ;
+    "> eval
+] unit-test
+
+[ t ] [
+    "fold-test" "compiler.tests.folding" lookup execute
+    "fold-test" "compiler.tests.folding" lookup execute
+    eq?
+] unit-test

basis/compiler/tests/insane.factor

@@ -1,4 +1,5 @@
 IN: compiler.tests
-USING: words kernel stack-checker alien.strings tools.test ;
+USING: words kernel stack-checker alien.strings tools.test
+compiler.units ;
 
-[ ] [ \ if redefined [ string>alien ] infer. ] unit-test
+[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test

basis/compiler/tests/redefine10.factor

@@ -0,0 +1,29 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+    <"
+    USING: kernel math classes ;
+    IN: compiler.tests.redefine10
+    MIXIN: my-mixin
+    INSTANCE: fixnum my-mixin
+    : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
+    "> eval
+] unit-test
+
+[ ] [
+    <"
+    USE: math
+    IN: compiler.tests.redefine10
+    INSTANCE: float my-mixin
+    "> eval
+] unit-test
+
+[ 2.0 ] [
+    1.0 "my-inline" "compiler.tests.redefine10" lookup execute
+] unit-test

basis/compiler/tests/redefine11.factor

@@ -0,0 +1,32 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel classes.mixin arrays ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+    <"
+    USING: kernel math classes arrays ;
+    IN: compiler.tests.redefine11
+    MIXIN: my-mixin
+    INSTANCE: array my-mixin
+    INSTANCE: fixnum my-mixin
+    GENERIC: my-generic ( a -- b )
+    M: my-mixin my-generic drop 0 ;
+    M: object my-generic drop 1 ;
+    : my-inline ( -- b ) { } my-generic ;
+    "> eval
+] unit-test
+
+[ ] [
+    [
+        array "my-mixin" "compiler.tests.redefine11" lookup
+        remove-mixin-instance
+    ] with-compilation-unit
+] unit-test
+
+[ 1 ] [
+    "my-inline" "compiler.tests.redefine11" lookup execute
+] unit-test

basis/compiler/tests/redefine6.factor

@@ -0,0 +1,33 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+    <"
+    USING: kernel kernel.private ;
+    IN: compiler.tests.redefine6
+    GENERIC: my-generic ( a -- b )
+    MIXIN: my-mixin
+    M: my-mixin my-generic drop 0 ;
+    : my-inline ( a -- b ) { my-mixin } declare my-generic ;
+    "> eval
+] unit-test
+
+[ ] [
+    <"
+    USING: kernel ;
+    IN: compiler.tests.redefine6
+    TUPLE: my-tuple ;
+    M: my-tuple my-generic drop 1 ;
+    INSTANCE: my-tuple my-mixin
+    "> eval
+] unit-test
+
+[ 1 ] [
+    "my-tuple" "compiler.tests.redefine6" lookup boa
+    "my-inline" "compiler.tests.redefine6" lookup execute
+] unit-test

basis/compiler/tests/redefine7.factor

@@ -0,0 +1,29 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+    <"
+    USING: kernel math ;
+    IN: compiler.tests.redefine7
+    MIXIN: my-mixin
+    INSTANCE: fixnum my-mixin
+    : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
+    "> eval
+] unit-test
+
+[ ] [
+    <"
+    USE: math
+    IN: compiler.tests.redefine7
+    INSTANCE: float my-mixin
+    "> eval
+] unit-test
+
+[ 2.0 ] [
+    1.0 "my-inline" "compiler.tests.redefine7" lookup execute
+] unit-test

basis/compiler/tests/redefine8.factor

@@ -0,0 +1,32 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+    <"
+    USING: kernel math math.order sorting ;
+    IN: compiler.tests.redefine8
+    MIXIN: my-mixin
+    INSTANCE: fixnum my-mixin
+    GENERIC: my-generic ( a -- b )
+    ! We add the bogus quotation here to hinder inlining
+    ! since otherwise we cannot trigger this bug.
+    M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
+    "> eval
+] unit-test
+
+[ ] [
+    <"
+    USE: math
+    IN: compiler.tests.redefine8
+    INSTANCE: float my-mixin
+    "> eval
+] unit-test
+
+[ 2.0 ] [
+    1.0 "my-generic" "compiler.tests.redefine8" lookup execute
+] unit-test

basis/compiler/tests/redefine9.factor

@@ -0,0 +1,35 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel generic.math ;
+IN: compiler.tests
+
+! Mixin redefinition did not recompile all necessary words.
+
+[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+    <"
+    USING: kernel math math.order sorting ;
+    IN: compiler.tests.redefine9
+    MIXIN: my-mixin
+    INSTANCE: fixnum my-mixin
+    GENERIC: my-generic ( a -- b )
+    ! We add the bogus quotation here to hinder inlining
+    ! since otherwise we cannot trigger this bug.
+    M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
+    "> eval
+] unit-test
+
+[ ] [
+    <"
+    USE: math
+    IN: compiler.tests.redefine9
+    TUPLE: my-tuple ;
+    INSTANCE: my-tuple my-mixin
+    "> eval
+] unit-test
+
+[
+    "my-tuple" "compiler.tests.redefine9" lookup boa
+    "my-generic" "compiler.tests.redefine9" lookup
+    execute
+] [ no-math-method? ] must-fail-with

basis/compiler/tree/cleanup/cleanup.factor

@@ -42,7 +42,7 @@ GENERIC: cleanup* ( node -- node/nodes )
 : cleanup-folding ( #call -- nodes )
     #! Replace a #call having a known result with a #drop of its
     #! inputs followed by #push nodes for the outputs.
-    [ word>> +inlined+ depends-on ]
+    [ word>> inlined-dependency depends-on ]
     [
         [ node-output-infos ] [ out-d>> ] bi
         [ [ literal>> ] dip #push ] 2map
@@ -50,11 +50,16 @@ GENERIC: cleanup* ( node -- node/nodes )
     [ in-d>> #drop ]
     tri prefix ;
 
+: add-method-dependency ( #call -- )
+    dup method>> word? [
+        [ word>> ] [ class>> ] bi depends-on-generic
+    ] [ drop ] if ;
+
 : cleanup-inlining ( #call -- nodes )
     [
         dup method>>
-        [ method>> dup word? [ +called+ depends-on ] [ drop ] if ]
+        [ add-method-dependency ]
-        [ word>> +inlined+ depends-on ] if
+        [ word>> inlined-dependency depends-on ] if
     ] [ body>> cleanup ] bi ;
 
 ! Removing overflow checks

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

@@ -106,7 +106,7 @@ M: #push remove-dead-code*
     ] [ drop f ] if ;
 
 : remove-flushable-call ( #call -- node )
-    [ word>> +inlined+ depends-on ]
+    [ word>> flushed-dependency depends-on ]
     [ in-d>> #drop remove-dead-code* ]
     bi ;
 

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

@@ -103,6 +103,9 @@ DEFER: copy-value
     [ [ allocation copy-allocation ] dip record-allocation ]
     2bi ;
 
+: copy-values ( from to -- )
+    [ copy-value ] 2each ;
+
 : copy-slot-value ( out slot# in -- )
     allocation {
         { [ dup not ] [ 3drop ] }

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

@@ -42,24 +42,26 @@ IN: compiler.tree.escape-analysis.recursive
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
+    [ label>> return>> in-d>> introduce-values ]
+    [
         [
             child>>
             [ first out-d>> introduce-values ]
             [ first analyze-recursive-phi ]
             [ (escape-analysis) ]
             tri
-    ] until-fixed-point ;
+        ] until-fixed-point
+    ] bi ;
 
 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
     #! Handled by #recursive
     drop ;
 
-: return-allocations ( node -- allocations )
-    label>> return>> node-input-allocations ;
-
 M: #call-recursive escape-analysis* ( #call-label -- )
-    [ ] [ return-allocations ] [ node-output-allocations ] tri
+    [ ] [ label>> return>> ] [ node-output-allocations ] tri
-    [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
+    [ [ node-input-allocations ] dip check-fixed-point ]
+    [ drop swap [ in-d>> ] [ out-d>> ] bi* copy-values ]
+    3bi ;
 
 M: #return-recursive escape-analysis* ( #return-recursive -- )
     [ call-next-method ]

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

@@ -13,7 +13,7 @@ IN: compiler.tree.escape-analysis.simple
 
 M: #terminate escape-analysis* drop ;
 
-M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
+M: #renaming escape-analysis* inputs/outputs copy-values ;
 
 M: #introduce escape-analysis* out-d>> unknown-allocations ;
 

basis/compiler/tree/finalization/finalization.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences
+compiler.tree compiler.tree.combinators ;
+IN: compiler.tree.finalization
+
+GENERIC: finalize* ( node -- nodes )
+
+M: #copy finalize* drop f ;
+
+M: #shuffle finalize*
+    dup shuffle-effect
+    [ in>> ] [ out>> ] bi sequence=
+    [ drop f ] when ;
+
+M: node finalize* ;
+
+: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

basis/compiler/tree/normalization/normalization.factor

@@ -204,5 +204,6 @@ M: node normalize* ;
     H{ } clone rename-map set
     dup [ collect-label-info ] each-node
     dup count-introductions make-values
-    [ (normalize) ] [ nip #introduce ] 2bi prefix
+    [ (normalize) ] [ nip ] 2bi
+    dup empty? [ drop ] [ #introduce prefix ] if
     rename-node-values ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -11,6 +11,7 @@ compiler.tree.strength-reduction
 compiler.tree.loop.detection
 compiler.tree.loop.inversion
 compiler.tree.branch-fusion
+compiler.tree.finalization
 compiler.tree.checker ;
 IN: compiler.tree.optimizer
 
@@ -25,6 +26,7 @@ IN: compiler.tree.optimizer
     unbox-tuples
     compute-def-use
     remove-dead-code
+    finalize
     ! strength-reduce
     ! USE: kernel
     ! compute-def-use

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

@@ -24,18 +24,19 @@ M: quotation splicing-nodes
     body>> (propagate) ;
 
 ! Dispatch elimination
-: eliminate-dispatch ( #call word/quot/f -- ? )
+: eliminate-dispatch ( #call class/f word/f -- ? )
-    [
+    dup [
+        [ >>class ] dip
         over method>> over = [ drop ] [
             2dup splicing-nodes
             [ >>method ] [ >>body ] bi*
         ] if
         propagate-body t
-    ] [ f >>method f >>body drop f ] if* ;
+    ] [ 2drop f >>method f >>body f >>class drop f ] if ;
 
-: inlining-standard-method ( #call word -- method/f )
+: inlining-standard-method ( #call word -- class/f method/f )
     [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
-    [ swap nth value-info class>> ] dip
+    [ swap nth value-info class>> dup ] dip
     specific-method ;
 
 : inline-standard-method ( #call word -- ? )
@@ -51,15 +52,17 @@ M: quotation splicing-nodes
         object
     } [ class<= ] with find nip ;
 
-: inlining-math-method ( #call word -- quot/f )
+: inlining-math-method ( #call word -- class/f quot/f )
     swap in-d>>
     first2 [ value-info class>> normalize-math-class ] bi@
-    3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
+    3dup math-both-known?
+    [ math-method* ] [ 3drop f ] if
+    number swap ;
 
 : inline-math-method ( #call word -- ? )
     dupd inlining-math-method eliminate-dispatch ;
 
-: inlining-math-partial ( #call word -- quot/f )
+: inlining-math-partial ( #call word -- class/f quot/f )
     [ "derived-from" word-prop first inlining-math-method ]
     [ nip 1quotation ] 2bi
     [ = not ] [ drop ] 2bi and ;

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -5,6 +5,8 @@ math.partial-dispatch math.intervals math.parser math.order
 layouts words sequences sequences.private arrays assocs classes
 classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
+definitions
+stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -280,6 +282,14 @@ generic-comparison-ops [
 ] +constraints+ set-word-prop
 
 \ instance? [
+    ! We need to force the caller word to recompile when the class
+    ! is redefined, since now we're making assumptions but the
+    ! class definition itself.
     dup literal>> class?
-    [ literal>> predicate-output-infos ] [ 2drop object-info ] if
+    [
+        literal>>
+        [ inlined-dependency depends-on ]
+        [ predicate-output-infos ]
+        bi
+    ] [ 2drop object-info ] if
 ] +outputs+ set-word-prop

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

@@ -2,9 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors kernel sequences sequences.private assocs words
 namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays byte-arrays strings
+classes.tuple.private continuations arrays
-math math.partial-dispatch math.private slots generic
+math math.partial-dispatch math.private slots generic definitions
 generic.standard generic.math
+stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -32,7 +33,14 @@ M: #push propagate-before
     [ set-value-info ] 2each ;
 
 M: #declare propagate-before
-    declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
+    #! We need to force the caller word to recompile when the
+    #! classes mentioned in the declaration are redefined, since
+    #! now we're making assumptions but their definitions.
+    declaration>> [
+        [ inlined-dependency depends-on ]
+        [ <class-info> swap refine-value-info ]
+        bi
+    ] assoc-each ;
 
 : predicate-constraints ( value class boolean-value -- constraint )
     [ [ is-instance-of ] dip t--> ]
@@ -74,7 +82,11 @@ M: #declare propagate-before
     } cond 2nip ;
 
 : propagate-predicate ( #call word -- infos )
-    [ in-d>> first value-info ] [ "predicating" word-prop ] bi*
+    #! We need to force the caller word to recompile when the class
+    #! is redefined, since now we're making assumptions but the
+    #! class definition itself.
+    [ in-d>> first value-info ]
+    [ "predicating" word-prop dup inlined-dependency depends-on ] bi*
     predicate-output-infos 1array ;
 
 : default-output-value-infos ( #call word -- infos )

basis/compiler/tree/tree.factor

@@ -17,7 +17,7 @@ TUPLE: #introduce < node out-d ;
 : #introduce ( out-d -- node )
     \ #introduce new swap >>out-d ;
 
-TUPLE: #call < node word in-d out-d body method info ;
+TUPLE: #call < node word in-d out-d body method class info ;
 
 : #call ( inputs outputs word -- node )
     \ #call new

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -46,3 +46,10 @@ TUPLE: empty-tuple ;
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
 
 [ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test
+
+TUPLE: box { i read-only } ;
+
+: box-test ( m -- n )
+    dup box-test i>> swap box-test drop box boa ; inline recursive
+
+[ ] [ [ T{ box f 34 } box-test i>> ] test-unboxing ] unit-test

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" =
+    thread>> name>> "Lock timeout-er" =
 ] must-fail-with
 
 :: read/write-test ( -- )

basis/concurrency/locks/locks.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: deques dlists kernel threads continuations math
-concurrency.conditions ;
+concurrency.conditions combinators.short-circuit accessors ;
 IN: concurrency.locks
 
 ! Simple critical sections
@@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ;
 <PRIVATE
 
 : acquire-lock ( lock timeout -- )
-    over lock-owner
+    over owner>>
-    [ 2dup >r lock-threads r> "lock" wait ] when drop
+    [ 2dup >r threads>> r> "lock" wait ] when drop
-    self swap set-lock-owner ;
+    self >>owner drop ;
 
 : release-lock ( lock -- )
-    f over set-lock-owner
+    f >>owner
-    lock-threads notify-1 ;
+    threads>> notify-1 ;
 
 : do-lock ( lock timeout quot acquire release -- )
     >r >r pick rot r> call ! use up  timeout acquire
@@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ;
 PRIVATE>
 
 : with-lock-timeout ( lock timeout quot -- )
-    pick lock-reentrant? [
+    pick reentrant?>> [
-        pick lock-owner self eq? [
+        pick owner>> self eq? [
             2nip call
         ] [
             (with-lock)
@@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ;
 <PRIVATE
 
 : add-reader ( lock -- )
-    dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
+    [ 1+ ] change-reader# drop ;
 
 : acquire-read-lock ( lock timeout -- )
-    over rw-lock-writer
+    over writer>>
-    [ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
+    [ 2dup >r readers>> r> "read lock" wait ] when drop
     add-reader ;
 
 : notify-writer ( lock -- )
-    rw-lock-writers notify-1 ;
+    writers>> notify-1 ;
 
 : remove-reader ( lock -- )
-    dup rw-lock-reader# 1- swap set-rw-lock-reader# ;
+    [ 1- ] change-reader# drop ;
 
 : release-read-lock ( lock -- )
     dup remove-reader
-    dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;
+    dup reader#>> zero? [ notify-writer ] [ drop ] if ;
 
 : acquire-write-lock ( lock timeout -- )
-    over rw-lock-writer pick rw-lock-reader# 0 > or
+    over writer>> pick reader#>> 0 > or
-    [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop
+    [ 2dup >r writers>> r> "write lock" wait ] when drop
-    self swap set-rw-lock-writer ;
+    self >>writer drop ;
 
 : release-write-lock ( lock -- )
-    f over set-rw-lock-writer
+    f >>writer
-    dup rw-lock-readers deque-empty?
+    dup readers>> deque-empty?
-    [ notify-writer ] [ rw-lock-readers notify-all ] if ;
+    [ notify-writer ] [ readers>> notify-all ] if ;
 
 : reentrant-read-lock-ok? ( lock -- ? )
     #! If we already have a write lock, then we can grab a read
     #! lock too.
-    rw-lock-writer self eq? ;
+    writer>> self eq? ;
 
 : reentrant-write-lock-ok? ( lock -- ? )
     #! The only case where we have a writer and > 1 reader is
     #! write -> read re-entrancy, and in this case we prohibit
     #! a further write -> read -> write re-entrancy.
-    dup rw-lock-writer self eq?
+    { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
-    swap rw-lock-reader# zero? and ;
 
 PRIVATE>
 

basis/concurrency/messaging/messaging-tests.factor

@@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes
 concurrency.count-downs accessors ;
 IN: concurrency.messaging.tests
 
-[ ] [ my-mailbox mailbox-data clear-deque ] unit-test
+[ ] [ my-mailbox data>> clear-deque ] unit-test
 
 [ "received" ] [ 
     [

basis/concurrency/messaging/messaging.factor

@@ -10,8 +10,8 @@ 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 -- )

basis/cpu/ppc/allot/allot.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel cpu.ppc.architecture cpu.ppc.assembler
 kernel.private namespaces math sequences generic arrays
-generator generator.registers generator.fixup system layouts
+compiler.generator compiler.generator.registers
+compiler.generator.fixup system layouts
 cpu.architecture alien ;
 IN: cpu.ppc.allot
 

basis/cpu/ppc/architecture/architecture.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
+USING: accessors alien.c-types cpu.ppc.assembler
-kernel kernel.private math memory namespaces sequences words
+cpu.architecture generic kernel kernel.private math memory
-assocs compiler.generator compiler.generator.registers
+namespaces sequences words assocs compiler.generator
-compiler.generator.fixup system layouts classes words.private
+compiler.generator.registers compiler.generator.fixup system
-alien combinators compiler.constants math.order ;
+layouts classes words.private alien combinators
+compiler.constants math.order ;
 IN: cpu.ppc.architecture
 
 ! PowerPC register assignments
@@ -65,8 +66,8 @@ M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
 GENERIC: loc>operand ( loc -- reg n )
 
-M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ;
+M: ds-loc loc>operand n>> cells neg ds-reg swap ;
-M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
+M: rs-loc loc>operand n>> cells neg rs-reg swap ;
 
 M: immediate load-literal
     [ v>operand ] bi@ LOAD ;

basis/cpu/ppc/intrinsics/intrinsics.factor

@@ -5,9 +5,10 @@ cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
 cpu.architecture kernel kernel.private math math.private
 namespaces sequences words generic quotations byte-arrays
 hashtables hashtables.private compiler.generator
-compiler.generator.registers generator.fixup sequences.private
+compiler.generator.registers compiler.generator.fixup
-sbufs vectors system layouts math.floats.private classes
+sequences.private sbufs vectors system layouts
-slots.private combinators compiler.constants ;
+math.floats.private classes slots.private combinators
+compiler.constants ;
 IN: cpu.ppc.intrinsics
 
 : %slot-literal-known-tag
@@ -436,44 +437,44 @@ IN: cpu.ppc.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-\ (tuple) [
+! \ (tuple) [
-    tuple "layout" get size>> 2 + cells %allot
+!     tuple "layout" get size>> 2 + cells %allot
-    ! Store layout
+!     ! Store layout
-    "layout" get 12 load-indirect
+!     "layout" get 12 load-indirect
-    12 11 cell STW
+!     12 11 cell STW
-    ! Store tagged ptr in reg
+!     ! Store tagged ptr in reg
-    "tuple" get tuple %store-tagged
+!     "tuple" get tuple %store-tagged
-] H{
+! ] H{
-    { +input+ { { [ ] "layout" } } }
+!     { +input+ { { [ ] "layout" } } }
-    { +scratch+ { { f "tuple" } } }
+!     { +scratch+ { { f "tuple" } } }
-    { +output+ { "tuple" } }
+!     { +output+ { "tuple" } }
-} define-intrinsic
+! } define-intrinsic
-
+! 
-\ (array) [
+! \ (array) [
-    array "n" get 2 + cells %allot
+!     array "n" get 2 + cells %allot
-    ! Store length
+!     ! Store length
-    "n" operand 12 LI
+!     "n" operand 12 LI
-    12 11 cell STW
+!     12 11 cell STW
-    ! Store tagged ptr in reg
+!     ! Store tagged ptr in reg
-    "array" get object %store-tagged
+!     "array" get object %store-tagged
-] H{
+! ] H{
-    { +input+ { { [ ] "n" } } }
+!     { +input+ { { [ ] "n" } } }
-    { +scratch+ { { f "array" } } }
+!     { +scratch+ { { f "array" } } }
-    { +output+ { "array" } }
+!     { +output+ { "array" } }
-} define-intrinsic
+! } define-intrinsic
-
+! 
-\ (byte-array) [
+! \ (byte-array) [
-    byte-array "n" get 2 cells + %allot
+!     byte-array "n" get 2 cells + %allot
-    ! Store length
+!     ! Store length
-    "n" operand 12 LI
+!     "n" operand 12 LI
-    12 11 cell STW
+!     12 11 cell STW
-    ! Store tagged ptr in reg
+!     ! Store tagged ptr in reg
-    "array" get object %store-tagged
+!     "array" get object %store-tagged
-] H{
+! ] H{
-    { +input+ { { [ ] "n" } } }
+!     { +input+ { { [ ] "n" } } }
-    { +scratch+ { { f "array" } } }
+!     { +scratch+ { { f "array" } } }
-    { +output+ { "array" } }
+!     { +output+ { "array" } }
-} define-intrinsic
+! } define-intrinsic
 
 \ <ratio> [
     ratio 3 cells %allot

basis/cpu/ppc/ppc.factor

@@ -1,14 +1,15 @@
-USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
+USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
-namespaces alien.c-types kernel system combinators ;
+cpu.architecture namespaces alien.c-types kernel system
+combinators ;
 
 {
     { [ os macosx? ] [
-        4 "longlong" c-type set-c-type-align
+        4 "longlong" c-type (>>align)
-        4 "ulonglong" c-type set-c-type-align
+        4 "ulonglong" c-type (>>align)
-        4 "double" c-type set-c-type-align
+        4 "double" c-type (>>align)
     ] }
     { [ os linux? ] [
-        t "longlong" c-type set-c-type-stack-align?
+        t "longlong" c-type (>>stack-align?)
-        t "ulonglong" c-type set-c-type-stack-align?
+        t "ulonglong" c-type (>>stack-align?)
     ] }
 } cond

basis/cpu/x86/32/32.factor

@@ -259,9 +259,9 @@ M: x86.32 %cleanup ( alien-node -- )
 M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
 
 os windows? [
-    cell "longlong" c-type set-c-type-align
+    cell "longlong" c-type (>>align)
-    cell "ulonglong" c-type set-c-type-align
+    cell "ulonglong" c-type (>>align)
-    4 "double" c-type set-c-type-align
+    4 "double" c-type (>>align)
 ] unless
 
 : (sse2?) ( -- ? ) "Intrinsic" throw ;

basis/cpu/x86/64/64.factor

@@ -174,10 +174,10 @@ USE: cpu.x86.intrinsics
 
 ! The ABI for passing structs by value is pretty messed up
 << "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type set-c-type-reg-class >>
+stack-params "__stack_value" c-type (>>reg-class) >>
 
 : struct-types&offset ( struct-type -- pairs )
-    struct-type-fields [
+    fields>> [
         [ class>> ] [ offset>> ] bi 2array
     ] map ;
 

basis/cpu/x86/architecture/architecture.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays cpu.x86.assembler
+USING: accessors alien alien.c-types arrays cpu.x86.assembler
 cpu.x86.assembler.private cpu.architecture kernel kernel.private
 math memory namespaces sequences words compiler.generator
 compiler.generator.registers compiler.generator.fixup system
@@ -16,8 +16,8 @@ HOOK: stack-save-reg cpu ( -- reg )
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
-M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
+M: ds-loc v>operand n>> ds-reg reg-stack ;
-M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
+M: rs-loc v>operand n>> rs-reg reg-stack ;
 
 M: int-regs %save-param-reg drop >r stack@ r> MOV ;
 M: int-regs %load-param-reg drop swap stack@ MOV ;

basis/debugger/debugger.factor

@@ -207,7 +207,7 @@ M: no-case summary
 
 M: slice-error error.
     "Cannot create slice because " write
-    slice-error-reason print ;
+    reason>> print ;
 
 M: bounds-error summary drop "Sequence index out of bounds" ;
 
@@ -232,14 +232,14 @@ M: immutable summary drop "Sequence is immutable" ;
 
 M: redefine-error error.
     "Re-definition of " write
-    redefine-error-def . ;
+    def>> . ;
 
 M: undefined summary
     drop "Calling a deferred word before it has been defined" ;
 
 M: no-compilation-unit error.
     "Attempting to define " write
-    no-compilation-unit-definition pprint
+    definition>> pprint
     " outside of a compilation unit" print ;
 
 M: no-vocab summary
@@ -299,9 +299,9 @@ M: string expected>string ;
 
 M: unexpected error.
     "Expected " write
-    dup unexpected-want expected>string write
+    dup want>> expected>string write
     " but got " write
-    unexpected-got expected>string print ;
+    got>> expected>string print ;
 
 M: lexer-error error.
     [ lexer-dump ] [ error>> error. ] bi ;

basis/documents/documents.factor

@@ -28,10 +28,10 @@ TUPLE: document < model locs ;
 : update-locs ( loc document -- )
     locs>> [ set-model ] with each ;
 
-: doc-line ( n document -- string ) model-value nth ;
+: doc-line ( n document -- string ) value>> nth ;
 
 : doc-lines ( from to document -- slice )
-    >r 1+ r> model-value <slice> ;
+    >r 1+ r> value>> <slice> ;
 
 : start-on-line ( document from line# -- n1 )
     >r dup first r> = [ nip second ] [ 2drop 0 ] if ;
@@ -99,7 +99,7 @@ TUPLE: document < model locs ;
     >r >r >r "" r> r> r> set-doc-range ;
 
 : last-line# ( document -- line )
-    model-value length 1- ;
+    value>> length 1- ;
 
 : validate-line ( line document -- line )
     last-line# min 0 max ;
@@ -117,7 +117,7 @@ TUPLE: document < model locs ;
     [ last-line# ] keep line-end ;
 
 : validate-loc ( loc document -- newloc )
-    over first over model-value length >= [
+    over first over value>> length >= [
         nip doc-end
     ] [
         over first 0 < [
@@ -128,7 +128,7 @@ TUPLE: document < model locs ;
     ] if ;
 
 : doc-string ( document -- str )
-    model-value "\n" join ;
+    value>> "\n" join ;
 
 : set-doc-string ( string document -- )
     >r string-lines V{ } like r> [ set-model ] keep

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/help/definitions/definitions.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: definitions help help.topics help.syntax
+USING: accessors definitions help help.topics help.syntax
 prettyprint.backend prettyprint words kernel effects ;
 IN: help.definitions
 
@@ -8,30 +8,30 @@ IN: help.definitions
 
 M: link definer drop \ ARTICLE: \ ; ;
 
-M: link where link-name article article-loc ;
+M: link where name>> article loc>> ;
 
-M: link set-where link-name article set-article-loc ;
+M: link set-where name>> article (>>loc) ;
 
-M: link forget* link-name remove-article ;
+M: link forget* name>> remove-article ;
 
 M: link definition article-content ;
 
 M: link synopsis*
     dup definer.
-    dup link-name pprint*
+    dup name>> pprint*
     article-title pprint* ;
 
 M: word-link definer drop \ HELP: \ ; ;
 
-M: word-link where link-name "help-loc" word-prop ;
+M: word-link where name>> "help-loc" word-prop ;
 
-M: word-link set-where link-name swap "help-loc" set-word-prop ;
+M: word-link set-where name>> swap "help-loc" set-word-prop ;
 
-M: word-link definition link-name "help" word-prop ;
+M: word-link definition name>> "help" word-prop ;
 
 M: word-link synopsis*
     dup definer.
-    link-name dup pprint-word
+    name>> dup pprint-word
     stack-effect. ;
 
-M: word-link forget* link-name remove-word-help ;
+M: word-link forget* name>> remove-word-help ;

basis/help/lint/lint.factor

@@ -131,7 +131,7 @@ M: help-error error.
 : run-help-lint ( prefix -- alist )
     [
         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
-        articles get keys "group-articles" set
+        group-articles "vocab-articles" set
         child-vocabs
         [ dup check-vocab ] { } map>assoc
         [ nip empty? not ] assoc-filter

basis/help/markup/markup.factor

@@ -143,13 +143,13 @@ M: f print-element drop ;
     link-style get [ write-object ] with-style ;
 
 : ($link) ( article -- )
-    [ dup article-name swap >link write-link ] ($span) ;
+    [ [ article-name ] [ >link ] bi write-link ] ($span) ;
 
 : $link ( element -- )
     first ($link) ;
 
 : ($long-link) ( object -- )
-    dup article-title swap >link write-link ;
+    [ article-title ] [ >link ] bi write-link ;
 
 : ($subsection) ( element quot -- )
     [

basis/help/syntax/syntax.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel parser sequences words help help.topics
+USING: accessors arrays kernel parser sequences words help
-namespaces vocabs definitions compiler.units ;
+help.topics namespaces vocabs definitions compiler.units ;
 IN: help.syntax
 
 : HELP:
@@ -16,7 +16,6 @@ IN: help.syntax
     over add-article >link r> remember-definition ; parsing
 
 : ABOUT:
-    scan-object
     in get vocab
-    dup +inlined+ changed-definition
+    dup changed-definition
-    set-vocab-help ; parsing
+    scan-object >>help drop ; parsing

basis/help/topics/topics-tests.factor

@@ -34,6 +34,6 @@ SYMBOL: foo
 ] unit-test
 
 [ { "testfile" 2 } ]
-[ { "test" 1 } articles get at article-loc ] unit-test
+[ { "test" 1 } articles get at loc>> ] unit-test
 
 [ ] [ { "test" 1 } remove-article ] unit-test

basis/help/topics/topics.factor

@@ -34,6 +34,8 @@ SYMBOL: article-xref
 article-xref global [ H{ } assoc-like ] change-at
 
 GENERIC: article-name ( topic -- string )
+GENERIC: article-title ( topic -- string )
+GENERIC: article-content ( topic -- content )
 GENERIC: article-parent ( topic -- parent )
 GENERIC: set-article-parent ( parent topic -- )
 
@@ -42,7 +44,9 @@ TUPLE: article title content loc ;
 : <article> ( title content -- article )
     f \ article boa ;
 
-M: article article-name article-title ;
+M: article article-name title>> ;
+M: article article-title title>> ;
+M: article article-content content>> ;
 
 ERROR: no-article name ;
 

basis/hints/hints.factor

@@ -55,7 +55,7 @@ IN: hints
 
 : HINTS:
     scan-word
-    [ +inlined+ changed-definition ]
+    [ redefined ]
     [ parse-definition "specializer" set-word-prop ] bi ;
     parsing
 

basis/io/mmap/mmap-docs.factor

@@ -5,8 +5,8 @@ IN: io.mmap
 HELP: mapped-file
 { $class-description "The class of memory-mapped files, opened by " { $link <mapped-file> } " and closed by " { $link close-mapped-file } ". The following two slots are of interest to users:"
     { $list
-        { { $link mapped-file-length } " - the length of the mapped file area, in bytes" }
+        { { $snippet "length" } " - the length of the mapped file area, in bytes" }
-        { { $link mapped-file-address } " - an " { $link alien } " pointing at the file's memory area" }
+        { { $snippet "address" } " - an " { $link alien } " pointing at the file's memory area" }
     }
 } ;
 
@@ -33,8 +33,7 @@ ARTICLE: "io.mmap" "Memory-mapped files"
 $nl
 "A utility combinator which wraps the above:"
 { $subsection with-mapped-file }
-"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
+"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly with the " { $snippet "address" } " slot." $nl
-{ $subsection mapped-file-address }
 "Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ;
 
 ABOUT: "io.mmap"

basis/io/ports/ports.factor

@@ -109,7 +109,7 @@ M: output-port stream-write1
 
 M: output-port stream-write
     dup check-disposed
-    over length over buffer>> buffer-size > [
+    over length over buffer>> size>> > [
         [ buffer>> size>> <groups> ]
         [ [ stream-write ] curry ] bi
         each

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,13 +75,13 @@ 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 ]
@@ -89,7 +89,7 @@ M: threaded-server handle-client* handler>> call ;
         if*
     ] [ 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/models/compose/compose-docs.factor

@@ -20,7 +20,7 @@ $nl
 
 HELP: <compose>
 { $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }
-{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }
+{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." }
 { $examples "See the example in the documentation for " { $link compose } "." } ;
 
 ARTICLE: "models-compose" "Composed models"

basis/models/delay/delay.factor

@@ -6,7 +6,7 @@ IN: models.delay
 TUPLE: delay < model model timeout alarm ;
 
 : update-delay-model ( delay -- )
-    [ delay-model model-value ] keep set-model ;
+    [ model>> value>> ] keep set-model ;
 
 : <delay> ( model timeout -- delay )
     f delay new-model
@@ -15,7 +15,7 @@ TUPLE: delay < model model timeout alarm ;
         [ add-dependency ] keep ;
 
 : cancel-delay ( delay -- )
-    delay-alarm [ cancel-alarm ] when* ;
+    alarm>> [ cancel-alarm ] when* ;
 
 : start-delay ( delay -- )
     dup

basis/models/history/history.factor

@@ -14,7 +14,7 @@ TUPLE: history < model back forward ;
         reset-history ;
 
 : (add-history) ( history to -- )
-    swap model-value dup [ swap push ] [ 2drop ] if ;
+    swap value>> dup [ swap push ] [ 2drop ] if ;
 
 : go-back/forward ( history to from -- )
     dup empty?
@@ -22,11 +22,11 @@ TUPLE: history < model back forward ;
     [ >r dupd (add-history) r> pop swap set-model ] if ;
 
 : go-back ( history -- )
-    dup history-forward over history-back go-back/forward ;
+    dup [ forward>> ] [ back>> ] bi go-back/forward ;
 
 : go-forward ( history -- )
-    dup history-back over history-forward go-back/forward ;
+    dup [ back>> ] [ forward>> ] bi go-back/forward ;
 
 : add-history ( history -- )
-    dup history-forward delete-all
+    dup forward>> delete-all
-    dup history-back (add-history) ;
+    dup back>> (add-history) ;

basis/models/models-docs.factor

@@ -63,12 +63,7 @@ HELP: set-model
 { $values { "value" object } { "model" model } }
 { $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
 
-{ set-model set-model-value change-model (change-model) } related-words
+{ set-model change-model (change-model) } related-words
-
-HELP: set-model-value ( value model -- )
-{ $values { "value" object } { "model" model } }
-{ $description "Changes the value of a model without notifying any observers registered with " { $link add-connection } "." }
-{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link set-model } ", which notifies observers." } ;
 
 HELP: change-model
 { $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }

basis/multiline/multiline.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces parser lexer kernel sequences words quotations math ;
+USING: namespaces parser lexer kernel sequences words quotations math
+accessors ;
 IN: multiline
 
 : next-line-text ( -- str )
-    lexer get dup next-line lexer-line-text ;
+    lexer get dup next-line line-text>> ;
 
 : (parse-here) ( -- )
     next-line-text [
@@ -22,7 +23,7 @@ IN: multiline
     parse-here 1quotation define-inline ; parsing
 
 : (parse-multiline-string) ( start-index end-text -- end-index )
-    lexer get lexer-line-text [
+    lexer get line-text>> [
         2dup start
         [ rot dupd >r >r swap subseq % r> r> length + ] [
             rot tail % "\n" % 0
@@ -32,8 +33,8 @@ IN: multiline
 
 : parse-multiline-string ( end-text -- str )
     [
-        lexer get lexer-column swap (parse-multiline-string)
+        lexer get column>> swap (parse-multiline-string)
-        lexer get set-lexer-column
+        lexer get (>>column)
     ] "" make rest but-last ;
 
 : <"

basis/peg/parsers/parsers.factor

@@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
 
 
 M: just-parser (compile) ( parser -- quot )
-  just-parser-p1 compile-parser just-pattern curry ;
+  p1>> compile-parser just-pattern curry ;
 
 : just ( parser -- parser )
   just-parser boa wrap-peg ;

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

@@ -105,7 +105,7 @@ M: sbuf pprint*
     dup "SBUF\" " "\"" pprint-string ;
 
 M: pathname pprint*
-    dup pathname-string "P\" " "\"" pprint-string ;
+    dup string>> "P\" " "\"" pprint-string ;
 
 ! Sequences
 : nesting-limit? ( -- ? )

basis/prettyprint/prettyprint-tests.factor

@@ -195,11 +195,11 @@ DEFER: parse-error-file
 
 : string-layout
     {
-        "USING: debugger io kernel lexer ;"
+        "USING: accessors debugger io kernel ;"
         "IN: prettyprint.tests"
         ": string-layout-test ( error -- )"
-        "    \"Expected \" write dup unexpected-want expected>string write"
+        "    \"Expected \" write dup want>> expected>string write"
-        "    \" but got \" write unexpected-got expected>string print ;"
+        "    \" but got \" write got>> expected>string print ;"
     } ;
 
 

basis/prettyprint/prettyprint.factor

@@ -172,7 +172,7 @@ M: hook-generic synopsis*
         [ definer. ]
         [ seeing-word ]
         [ pprint-word ]
-        [ "combination" word-prop hook-combination-var pprint* ]
+        [ "combination" word-prop var>> pprint* ]
         [ stack-effect. ]
     } cleave ;
 

basis/prettyprint/sections/sections.factor

@@ -115,10 +115,10 @@ M: object short-section? section-fits? ;
 
 : pprint-section ( section -- )
     dup short-section? [
-        dup section-style [ short-section ] with-style
+        dup style>> [ short-section ] with-style
     ] [
         [ <long-section ]
-        [ dup section-style [ long-section ] with-style ]
+        [ dup style>> [ long-section ] with-style ]
         [ long-section> ]
         tri
     ] if ;
@@ -205,7 +205,7 @@ TUPLE: text < section string ;
         swap >>style
         swap >>string ;
 
-M: text short-section text-string write ;
+M: text short-section string>> write ;
 
 M: text long-section short-section ;
 
@@ -291,17 +291,13 @@ SYMBOL: next
 
 : split-groups ( ? -- ) [ t , ] when ;
 
-M: f section-start-group? drop t ;
-
-M: f section-end-group? drop f ;
-
 : split-before ( section -- )
-    [ section-start-group? prev get section-end-group? and ]
+    [ start-group?>> prev get [ end-group?>> ] [ t ] if* and ]
     [ flow? prev get flow? not and ]
     bi or split-groups ;
 
 : split-after ( section -- )
-    section-end-group? split-groups ;
+    [ end-group?>> ] [ f ] if* split-groups ;
 
 : group-flow ( seq -- newseq )
     [

basis/stack-checker/backend/backend.factor

@@ -8,29 +8,6 @@ sets generic.standard.engines.tuple stack-checker.state
 stack-checker.visitor stack-checker.errors ;
 IN: stack-checker.backend
 
-! Word properties we use
-SYMBOL: visited
-
-: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
-
-: (redefined) ( word -- )
-    dup visited get key? [ drop ] [
-        [ reset-on-redefine reset-props ]
-        [ visited get conjoin ]
-        [
-            crossref get at keys
-            [ word? ] filter
-            [
-                [ reset-on-redefine [ word-prop ] with contains? ]
-                [ inline? ]
-                bi or
-            ] filter
-            [ (redefined) ] each
-        ] tri
-    ] if ;
-
-M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
-
 : push-d ( obj -- ) meta-d get push ;
 
 : pop-d  ( -- obj )
@@ -72,7 +49,7 @@ GENERIC: apply-object ( obj -- )
 
 M: wrapper apply-object
     wrapped>>
-    [ dup word? [ +called+ depends-on ] [ drop ] if ]
+    [ dup word? [ called-dependency depends-on ] [ drop ] if ]
     [ push-literal ]
     bi ;
 
@@ -175,6 +152,7 @@ M: object apply-object push-literal ;
             init-known-values
             stack-visitor off
             dependencies off
+            generic-dependencies off
             [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
             [ finish-word current-effect ]
             bi

basis/stack-checker/inlining/inlining.factor

@@ -140,7 +140,7 @@ SYMBOL: enter-out
     ] [ undeclared-recursion-error inference-error ] if ;
 
 : inline-word ( word -- )
-    [ +inlined+ depends-on ]
+    [ inlined-dependency depends-on ]
     [
         {
             { [ dup inline-recursive-label ] [ call-recursive-inline-word ] }

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

@@ -176,7 +176,7 @@ do-primitive alien-invoke alien-indirect alien-callback
 SYMBOL: +primitive+
 
 : non-inline-word ( word -- )
-    dup +called+ depends-on
+    dup called-dependency depends-on
     {
         { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
         { [ dup "special" word-prop ] [ infer-special ] }

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

@@ -9,22 +9,22 @@ definitions ;
 SYMBOL: a
 SYMBOL: b
 
-[ ] [ a +called+ depends-on ] unit-test
+[ ] [ a called-dependency depends-on ] unit-test
 
-[ H{ { a +called+ } } ] [
+[ H{ { a called-dependency } } ] [
-    [ a +called+ depends-on ] computing-dependencies
+    [ a called-dependency depends-on ] computing-dependencies
 ] unit-test
 
-[ H{ { a +called+ } { b +inlined+ } } ] [
+[ H{ { a called-dependency } { b inlined-dependency } } ] [
     [
-        a +called+ depends-on b +inlined+ depends-on
+        a called-dependency depends-on b inlined-dependency depends-on
     ] computing-dependencies
 ] unit-test
 
-[ H{ { a +inlined+ } { b +inlined+ } } ] [
+[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
     [
-        a +inlined+ depends-on
+        a inlined-dependency depends-on
-        a +called+ depends-on
+        a called-dependency depends-on
-        b +inlined+ depends-on
+        b inlined-dependency depends-on
     ] computing-dependencies
 ] unit-test

basis/stack-checker/state/state.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs namespaces sequences kernel definitions math
-effects accessors words stack-checker.errors ;
+effects accessors words fry classes.algebra stack-checker.errors
+compiler.units ;
 IN: stack-checker.state
 
 : <value> ( -- value ) \ <value> counter ;
@@ -88,9 +89,15 @@ SYMBOL: meta-r
 SYMBOL: dependencies
 
 : depends-on ( word how -- )
-    swap dependencies get dup [
+    dependencies get dup
-        2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
+    [ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ;
-    ] [ 3drop ] if ;
+
+! Generic words that the current quotation depends on
+SYMBOL: generic-dependencies
+
+: depends-on-generic ( generic class -- )
+    generic-dependencies get dup
+    [ swap '[ null or , class-or ] change-at ] [ 3drop ] if ;
 
 ! Words we've inferred the stack effect of, for rollback
 SYMBOL: recorded

basis/stack-checker/transforms/transforms.factor

@@ -46,7 +46,7 @@ SYMBOL: +transform-n+
     ] [ 2drop give-up-transform ] if ;
 
 : apply-transform ( word -- )
-    [ +inlined+ depends-on ] [
+    [ inlined-dependency depends-on ] [
         [ ]
         [ +transform-quot+ word-prop ]
         [ +transform-n+ word-prop ]
@@ -55,7 +55,7 @@ SYMBOL: +transform-n+
     ] bi ;
 
 : apply-macro ( word -- )
-    [ +inlined+ depends-on ] [
+    [ inlined-dependency depends-on ] [
         [ ]
         [ "macro" word-prop ]
         [ "declared-effect" word-prop in>> length ]
@@ -92,13 +92,13 @@ SYMBOL: +transform-n+
 \ spread [ spread>quot ] 1 define-transform
 
 \ (call-next-method) [
-    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+    [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi
 ] 2 define-transform
 
 ! Constructors
 \ boa [
     dup tuple-class? [
-        dup +inlined+ depends-on
+        dup inlined-dependency depends-on
         [ "boa-check" word-prop ]
         [ tuple-layout '[ , <tuple-boa> ] ]
         bi append
@@ -107,7 +107,7 @@ SYMBOL: +transform-n+
 
 \ new [
     dup tuple-class? [
-        dup +inlined+ depends-on
+        dup inlined-dependency depends-on
         dup all-slots rest-slice ! delegate slot
         [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
     ] [ drop f ] if

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

@@ -35,13 +35,13 @@ namespaces continuations layouts accessors ;
 
 [ t ] [ 1200000 small-enough? ] unit-test
 
-[ ] [ "tetris" shake-and-bake ] unit-test
+! [ ] [ "tetris" shake-and-bake ] unit-test
-
+! 
-[ t ] [ 1500000 small-enough? ] unit-test
+! [ t ] [ 1500000 small-enough? ] unit-test
-
+! 
-[ ] [ "bunny" shake-and-bake ] unit-test
+! [ ] [ "bunny" shake-and-bake ] unit-test
-
+! 
-[ t ] [ 2500000 small-enough? ] unit-test
+! [ t ] [ 2500000 small-enough? ] unit-test
 
 {
     "tools.deploy.test.1"

basis/tools/deploy/test/2/deploy.factor

@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-word-defs? f }
-    { deploy-random? f }
-    { deploy-name "tools.deploy.test.2" }
-    { deploy-threads? t }
-    { deploy-compiler? t }
     { deploy-math? t }
-    { deploy-c-types? f }
+    { deploy-compiler? t }
-    { deploy-io 2 }
+    { deploy-reflection 2 }
-    { deploy-reflection 1 }
     { deploy-ui? f }
-    { "stop-after-last-window?" t }
     { deploy-word-props? f }
+    { deploy-threads? t }
+    { deploy-c-types? f }
+    { deploy-random? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "tools.deploy.test.2" }
+    { deploy-io 2 }
+    { deploy-word-defs? f }
 }

basis/tools/threads/threads.factor

@@ -6,14 +6,14 @@ 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>> [
             key>> millis [-] number>string write
             " ms" write
         ] when*

basis/tools/vocabs/browser/browser.factor

@@ -181,12 +181,12 @@ M: vocab-spec article-parent drop "vocab-index" ;
 M: vocab-tag >link ;
 
 M: vocab-tag article-title
-    vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
+    name>> "Vocabularies tagged ``" swap "''" 3append ;
 
-M: vocab-tag article-name vocab-tag-name ;
+M: vocab-tag article-name name>> ;
 
 M: vocab-tag article-content
-    \ $tagged-vocabs swap vocab-tag-name 2array ;
+    \ $tagged-vocabs swap name>> 2array ;
 
 M: vocab-tag article-parent drop "vocab-index" ;
 
@@ -195,12 +195,12 @@ M: vocab-tag summary article-title ;
 M: vocab-author >link ;
 
 M: vocab-author article-title
-    vocab-author-name "Vocabularies by " prepend ;
+    name>> "Vocabularies by " prepend ;
 
-M: vocab-author article-name vocab-author-name ;
+M: vocab-author article-name name>> ;
 
 M: vocab-author article-content
-    \ $authored-vocabs swap vocab-author-name 2array ;
+    \ $authored-vocabs swap name>> 2array ;
 
 M: vocab-author article-parent drop "vocab-index" ;
 

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
+        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 ;
 
@@ -163,7 +163,7 @@ SYMBOL: +stopped+
     ] change-frame ;
 
 : status ( -- symbol )
-    walker-status tget model-value ;
+    walker-status tget value>> ;
 
 : set-status ( symbol -- )
     walker-status tget set-model ;
@@ -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/ui/clipboards/clipboards.factor

@@ -1,10 +1,22 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ui.gadgets ui.gestures namespaces ;
+
+USING: kernel accessors ui.gadgets ui.gestures namespaces ;
+
 IN: ui.clipboards
 
 ! Two text transfer buffers
+
 TUPLE: clipboard contents ;
+
+GENERIC: clipboard-contents ( clipboard -- string )
+
+GENERIC: set-clipboard-contents ( string clipboard -- )
+
+M: clipboard clipboard-contents contents>> ;
+
+M: clipboard set-clipboard-contents (>>contents) ;
+
 : <clipboard> ( -- clipboard ) "" clipboard boa ;
 
 GENERIC: paste-clipboard ( gadget clipboard -- )
@@ -20,11 +32,10 @@ SYMBOL: clipboard
 SYMBOL: selection
 
 : gadget-copy ( gadget clipboard -- )
-    over gadget-selection? [
+    over gadget-selection?
-        >r [ gadget-selection ] keep r> copy-clipboard
+        [ >r [ gadget-selection ] keep r> copy-clipboard ]
-    ] [
+        [ 2drop ]
-        2drop
+    if ;
-    ] if ;
 
 : com-copy ( gadget -- ) clipboard get gadget-copy ;
 

basis/ui/freetype/freetype-docs.factor

@@ -16,12 +16,35 @@ HELP: init-freetype
 { $notes "Do not call this word if you are using the UI." } ;
 
 HELP: font
-{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
+
-    { $list
+{ $class-description
-        { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
+
-        { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." }
+"A font which has been loaded by FreeType. Font instances have the following slots:"
-        { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
+
+{
+  $list
+  {
+    { $snippet "ascent"  } ", "
+    { $snippet "descent" } ", "
+    { $snippet "height"  } " - metrics."
   }
+
+  {
+    { $snippet "handle" }
+    " - alien pointer to an "
+    { $snippet "FT_Face" } "."
+  }
+
+  {
+    { $snippet "widths" }
+    " - sequence of character widths. Use "
+    { $snippet "width" }
+    " and "
+    { $snippet "width" }
+    " to compute string widths instead of reading this sequence directly."
+  }
+}
+
 } ;
 
 HELP: close-freetype

basis/ui/freetype/freetype.factor

@@ -33,7 +33,7 @@ ascent descent height handle widths ;
 
 M: font hashcode* drop font hashcode* ;
 
-: close-font ( font -- ) font-handle FT_Done_Face ;
+: close-font ( font -- ) handle>> FT_Done_Face ;
 
 : close-freetype ( -- )
     global [
@@ -111,11 +111,11 @@ M: freetype-renderer open-font ( font -- open-font )
     freetype drop open-fonts get [ <font> ] cache ;
 
 : load-glyph ( font char -- glyph )
-    >r font-handle dup r> 0 FT_Load_Char
+    >r handle>> dup r> 0 FT_Load_Char
     freetype-error face-glyph ;
 
 : char-width ( open-font char -- w )
-    over font-widths [
+    over widths>> [
         dupd load-glyph glyph-hori-advance ft-ceil
     ] cache nip ;
 
@@ -123,7 +123,7 @@ M: freetype-renderer string-width ( open-font string -- w )
     0 -rot [ char-width + ] with each ;
 
 M: freetype-renderer string-height ( open-font string -- h )
-    drop font-height ;
+    drop height>> ;
 
 : glyph-size ( glyph -- dim )
     dup glyph-hori-advance ft-ceil
@@ -166,7 +166,7 @@ M: freetype-renderer string-height ( open-font string -- h )
 
 : glyph-texture-loc ( glyph font -- loc )
     over glyph-hori-bearing-x ft-floor -rot
-    font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
+    ascent>> swap glyph-hori-bearing-y - ft-floor 2array ;
 
 : glyph-texture-size ( glyph -- dim )
     [ glyph-bitmap-width next-power-of-2 ]
@@ -203,7 +203,7 @@ M: freetype-renderer string-height ( open-font string -- h )
     ] do-enabled ;
 
 : font-sprites ( font world -- open-font sprites )
-    world-fonts [ open-font H{ } clone 2array ] cache first2 ;
+    fonts>> [ open-font H{ } clone 2array ] cache first2 ;
 
 M: freetype-renderer draw-string ( font string loc -- )
     >r >r world get font-sprites r> r> (draw-string) ;

basis/ui/gadgets/books/books-docs.factor

@@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.gadgets models ;
 IN: ui.gadgets.books
 
 HELP: book
-{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
+{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $snippet "visible?" } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
 $nl
 "Books are created by calling " { $link <book> } "." } ;
 

basis/ui/gadgets/books/books.factor

@@ -5,7 +5,7 @@ IN: ui.gadgets.books
 
 TUPLE: book < gadget ;
 
-: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
+: hide-all ( book -- ) children>> [ hide-gadget ] each ;
 
 : current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
 

basis/ui/gadgets/buttons/buttons-docs.factor

@@ -5,9 +5,9 @@ IN: ui.gadgets.buttons
 HELP: button
 { $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
 $nl
-"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
+"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-paint } "."
 $nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
 
 HELP: <button>
 { $values { "label" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
@@ -28,10 +28,10 @@ HELP: <repeat-button>
 HELP: button-paint
 { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
     { $list
-        { { $link button-paint-plain } " - the button is inactive" }
+        { { $snippet "plain"    } " - the button is inactive" }
-        { { $link button-paint-rollover } " - the button is under the mouse" }
+        { { $snippet "rollover" } " - the button is under the mouse" }
-        { { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
+        { { $snippet "pressed"  } " - the button is under the mouse and a mouse button is held down" }
-        { { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> }  }
+        { { $snippet "selected" } " - the button is selected (see " { $link <toggle-buttons> }  }
     }
 "The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
 

basis/ui/gadgets/buttons/buttons.factor

@@ -25,14 +25,13 @@ TUPLE: button < border pressed? selected? quot ;
     dup mouse-clicked?
     over button-rollover? and
     buttons-down? and
-    over set-button-pressed?
+    over (>>pressed?)
     relayout-1 ;
 
 : if-clicked ( button quot -- )
     >r dup button-update dup button-rollover? r> [ drop ] if ;
 
-: button-clicked ( button -- )
+: button-clicked ( button -- ) dup quot>> if-clicked ;
-    dup button-quot if-clicked ;
 
 button H{
     { T{ button-up } [ button-clicked ] }
@@ -106,7 +105,7 @@ TUPLE: checkmark-paint color ;
 C: <checkmark-paint> checkmark-paint
 
 M: checkmark-paint draw-interior
-    checkmark-paint-color set-color
+    color>> set-color
     origin get [
         rect-dim
         { 0 0 } over gl-line
@@ -119,9 +118,9 @@ M: checkmark-paint draw-interior
     black <solid>
     black <checkmark-paint>
     <button-paint>
-    over set-gadget-interior
+    over (>>interior)
     black <solid>
-    swap set-gadget-boundary ;
+    swap (>>boundary) ;
 
 : <checkmark> ( -- gadget )
     <gadget>
@@ -145,18 +144,18 @@ TUPLE: checkbox < button ;
         swap >>model ;
 
 M: checkbox model-changed
-    swap model-value over set-button-selected? relayout-1 ;
+    swap model-value over (>>selected?) relayout-1 ;
 
 TUPLE: radio-paint color ;
 
 C: <radio-paint> radio-paint
 
 M: radio-paint draw-interior
-    radio-paint-color set-color
+    color>> set-color
     origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
 
 M: radio-paint draw-boundary
-    radio-paint-color set-color
+    color>> set-color
     origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
 
 : radio-knob-theme ( gadget -- )
@@ -165,9 +164,9 @@ M: radio-paint draw-boundary
     black <radio-paint>
     black <radio-paint>
     <button-paint>
-    over set-gadget-interior
+    over (>>interior)
     black <radio-paint>
-    swap set-gadget-boundary ;
+    swap (>>boundary) ;
 
 : <radio-knob> ( -- gadget )
     <gadget>
@@ -184,8 +183,8 @@ TUPLE: radio-control < button value ;
 
 M: radio-control model-changed
     swap model-value
-    over radio-control-value =
+    over value>> =
-    over set-button-selected?
+    over (>>selected?)
     relayout-1 ;
 
 : <radio-controls> ( parent model assoc quot -- parent )

basis/ui/gadgets/editors/editors-docs.factor

@@ -7,32 +7,34 @@ HELP: editor
 $nl
 "Editors have the following slots:"
 { $list
-    { { $link editor-font } " - a font specifier." }
+    { { $snippet "font" } " - a font specifier." }
-    { { $link editor-color } " - text color specifier." }
+    { { $snippet "color" } " - text color specifier." }
-    { { $link editor-caret-color } " - caret color specifier." }
+    { { $snippet "caret-color" } " - caret color specifier." }
-    { { $link editor-selection-color } " - selection background color specifier." }
+    { { $snippet "selection-color" } " - selection background color specifier." }
-    { { $link editor-caret } " - a model storing a line/column pair." }
+    { { $snippet "caret" } " - a model storing a line/column pair." }
-    { { $link editor-mark } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
+    { { $snippet "mark" } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
-    { { $link editor-focused? } " - a boolean." }
+    { { $snippet "focused?" } " - a boolean." }
 } } ;
 
 HELP: <editor>
 { $values { "editor" "a new " { $link editor } } }
 { $description "Creates a new " { $link editor } " with an empty document." } ;
 
-HELP: editor-caret ( editor -- caret )
+! 'editor-caret' is now an old accessor, but it's documented as a word here. Maybe move this description somewhere else.
-{ $values { "editor" editor } { "caret" model } }
-{ $description "Outputs a " { $link model } " holding the current caret location." } ;
 
-{ editor-caret editor-caret* editor-mark editor-mark* } related-words
+! HELP: editor-caret ( editor -- caret )
+! { $values { "editor" editor } { "caret" model } }
+! { $description "Outputs a " { $link model } " holding the current caret location." } ;
+
+{ editor-caret* editor-mark* } related-words
 
 HELP: editor-caret*
 { $values { "editor" editor } { "loc" "a pair of integers" } }
 { $description "Outputs the current caret location as a line/column number pair." } ;
 
-HELP: editor-mark ( editor -- mark )
+! HELP: editor-mark ( editor -- mark )
-{ $values { "editor" editor } { "mark" model } }
+! { $values { "editor" editor } { "mark" model } }
-{ $description "Outputs a " { $link model } " holding the current mark location." } ;
+! { $description "Outputs a " { $link model } " holding the current mark location." } ;
 
 HELP: editor-mark*
 { $values { "editor" editor } { "loc" "a pair of integers" } }
@@ -74,9 +76,7 @@ HELP: set-editor-string
 
 ARTICLE: "gadgets-editors-selection" "The caret and mark"
 "If there is no selection, the caret and the mark are at the same location; otherwise the mark delimits the end-point of the selection opposite the caret."
-{ $subsection editor-caret }
 { $subsection editor-caret* }
-{ $subsection editor-mark }
 { $subsection editor-mark* }
 { $subsection change-caret }
 { $subsection change-caret&mark }

basis/ui/gadgets/editors/editors.factor

@@ -38,50 +38,50 @@ focused? ;
 : activate-editor-model ( editor model -- )
     2dup add-connection
     dup activate-model
-    swap gadget-model add-loc ;
+    swap model>> add-loc ;
 
 : deactivate-editor-model ( editor model -- )
     2dup remove-connection
     dup deactivate-model
-    swap gadget-model remove-loc ;
+    swap model>> remove-loc ;
 
 M: editor graft*
     dup
-    dup editor-caret activate-editor-model
+    dup caret>> activate-editor-model
-    dup editor-mark activate-editor-model ;
+    dup mark>> activate-editor-model ;
 
 M: editor ungraft*
     dup
-    dup editor-caret deactivate-editor-model
+    dup caret>> deactivate-editor-model
-    dup editor-mark deactivate-editor-model ;
+    dup mark>> deactivate-editor-model ;
 
-: editor-caret* ( editor -- loc ) editor-caret model-value ;
+: editor-caret* ( editor -- loc ) caret>> model-value ;
 
-: editor-mark* ( editor -- loc ) editor-mark model-value ;
+: editor-mark* ( editor -- loc ) mark>> model-value ;
 
 : set-caret ( loc editor -- )
-    [ gadget-model validate-loc ] keep
+    [ model>> validate-loc ] keep
-    editor-caret set-model ;
+    caret>> set-model ;
 
 : change-caret ( editor quot -- )
-    over >r >r dup editor-caret* swap gadget-model r> call r>
+    over >r >r dup editor-caret* swap model>> r> call r>
     set-caret ; inline
 
 : mark>caret ( editor -- )
-    dup editor-caret* swap editor-mark set-model ;
+    dup editor-caret* swap mark>> set-model ;
 
 : change-caret&mark ( editor quot -- )
     over >r change-caret r> mark>caret ; inline
 
 : editor-line ( n editor -- str ) control-value nth ;
 
-: editor-font* ( editor -- font ) editor-font open-font ;
+: editor-font* ( editor -- font ) font>> open-font ;
 
 : line-height ( editor -- n )
     editor-font* "" string-height ;
 
 : y>line ( y editor -- line# )
-    [ line-height / >fixnum ] keep gadget-model validate-line ;
+    [ line-height / >fixnum ] keep model>> validate-line ;
 
 : point>loc ( point editor -- loc )
     [
@@ -96,11 +96,9 @@ M: editor ungraft*
 : click-loc ( editor model -- )
     >r clicked-loc r> set-model ;
 
-: focus-editor ( editor -- )
+: focus-editor ( editor -- ) t over (>>focused?) relayout-1 ;
-    t over set-editor-focused? relayout-1 ;
 
-: unfocus-editor ( editor -- )
+: unfocus-editor ( editor -- ) f over (>>focused?) relayout-1 ;
-    f over set-editor-focused? relayout-1 ;
 
 : (offset>x) ( font col# str -- x )
     swap head-slice string-width ;
@@ -121,15 +119,15 @@ M: editor ungraft*
     line-height 0 swap 2array ;
 
 : scroll>caret ( editor -- )
-    dup gadget-graft-state second [
+    dup graft-state>> second [
         dup caret-loc over caret-dim { 1 0 } v+ <rect>
         over scroll>rect
     ] when drop ;
 
 : draw-caret ( -- )
-    editor get editor-focused? [
+    editor get focused?>> [
         editor get
-        dup editor-caret-color set-color
+        dup caret-color>> set-color
         dup caret-loc origin get v+
         swap caret-dim over v+
         [ { 0.5 -0.5 } v+ ] bi@ gl-line
@@ -142,7 +140,7 @@ M: editor ungraft*
     line-translation gl-translate ;
 
 : draw-line ( editor str -- )
-    >r editor-font r> { 0 0 } draw-string ;
+    >r font>> r> { 0 0 } draw-string ;
 
 : first-visible-line ( editor -- n )
     clip get rect-loc second origin get second -
@@ -157,7 +155,7 @@ M: editor ungraft*
         swap
         dup first-visible-line \ first-visible-line set
         dup last-visible-line \ last-visible-line set
-        dup gadget-model document set
+        dup model>> document set
         editor set
         call
     ] with-scope ; inline
@@ -173,7 +171,7 @@ M: editor ungraft*
 
 : draw-lines ( -- )
     \ first-visible-line get [
-        editor get dup editor-color set-color
+        editor get dup color>> set-color
         dup visible-lines
         [ draw-line 1 translate-lines ] with each
     ] with-editor-translation ;
@@ -192,7 +190,7 @@ M: editor ungraft*
     (draw-selection) ;
 
 : draw-selection ( -- )
-    editor get editor-selection-color set-color
+    editor get selection-color>> set-color
     editor get selection-start/end
     over first [
         2dup [
@@ -227,24 +225,24 @@ M: editor gadget-selection?
     selection-start/end = not ;
 
 M: editor gadget-selection
-    [ selection-start/end ] keep gadget-model doc-range ;
+    [ selection-start/end ] keep model>> doc-range ;
 
 : remove-selection ( editor -- )
-    [ selection-start/end ] keep gadget-model remove-doc-range ;
+    [ selection-start/end ] keep model>> remove-doc-range ;
 
 M: editor user-input*
-    [ selection-start/end ] keep gadget-model set-doc-range t ;
+    [ selection-start/end ] keep model>> set-doc-range t ;
 
 : editor-string ( editor -- string )
-    gadget-model doc-string ;
+    model>> doc-string ;
 
 : set-editor-string ( string editor -- )
-    gadget-model set-doc-string ;
+    model>> set-doc-string ;
 
 M: editor gadget-text* editor-string % ;
 
 : extend-selection ( editor -- )
-    dup request-focus dup editor-caret click-loc ;
+    dup request-focus dup caret>> click-loc ;
 
 : mouse-elt ( -- element )
     hand-click# get {
@@ -257,12 +255,12 @@ M: editor gadget-text* editor-string % ;
 
 : drag-selection-caret ( loc editor element -- loc )
     >r [ drag-direction? ] 2keep
-    gadget-model
+    model>>
     r> prev/next-elt ? ;
 
 : drag-selection-mark ( loc editor element -- loc )
     >r [ drag-direction? not ] 2keep
-    nip dup editor-mark* swap gadget-model
+    nip dup editor-mark* swap model>>
     r> prev/next-elt ? ;
 
 : drag-caret&mark ( editor -- caret mark )
@@ -272,8 +270,8 @@ M: editor gadget-text* editor-string % ;
 
 : drag-selection ( editor -- )
     dup drag-caret&mark
-    pick editor-mark set-model
+    pick mark>> set-model
-    swap editor-caret set-model ;
+    swap caret>> set-model ;
 
 : editor-cut ( editor clipboard -- )
     dupd gadget-copy remove-selection ;
@@ -282,8 +280,8 @@ M: editor gadget-text* editor-string % ;
     over gadget-selection? [
         drop nip remove-selection
     ] [
-        over >r >r dup editor-caret* swap gadget-model
+        over >r >r dup editor-caret* swap model>>
-        r> call r> gadget-model remove-doc-range
+        r> call r> model>> remove-doc-range
     ] if ; inline
 
 : editor-delete ( editor elt -- )
@@ -305,11 +303,11 @@ M: editor gadget-text* editor-string % ;
     dupd editor-select-next mark>caret ;
 
 : editor-select ( from to editor -- )
-    tuck editor-caret set-model editor-mark set-model ;
+    tuck caret>> set-model mark>> set-model ;
 
 : select-elt ( editor elt -- )
     over >r
-    >r dup editor-caret* swap gadget-model r> prev/next-elt
+    >r dup editor-caret* swap model>> r> prev/next-elt
     r> editor-select ;
 
 : start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
@@ -318,7 +316,7 @@ M: editor gadget-text* editor-string % ;
 
 : position-caret ( editor -- )
     mouse-elt dup T{ one-char-elt } =
-    [ drop dup extend-selection dup editor-mark click-loc ]
+    [ drop dup extend-selection dup mark>> click-loc ]
     [ select-elt ] if ;
 
 : insert-newline ( editor -- ) "\n" swap user-input ;

basis/ui/gadgets/gadgets-docs.factor

@@ -31,7 +31,7 @@ HELP: user-input*
 HELP: children-on
 { $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
 { $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." }
-{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
+{ $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
 
 HELP: pick-up
 { $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
@@ -57,7 +57,7 @@ HELP: gadget-selection
 
 HELP: relayout
 { $values { "gadget" gadget } }
-{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
+{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $snippet "root?" } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
 
 HELP: relayout-1
 { $values { "gadget" gadget } }
@@ -170,7 +170,7 @@ HELP: focusable-child
 { $values { "gadget" gadget } { "child" gadget } }
 { $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
 
-{ control-value set-control-value gadget-model } related-words
+{ control-value set-control-value } related-words
 
 HELP: control-value
 { $values { "control" gadget } { "value" object } }
@@ -181,10 +181,9 @@ HELP: set-control-value
 { $description "Sets the value of the control's model." } ;
 
 ARTICLE: "ui-control-impl" "Implementing controls"
-"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
+"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $snippet "model" } " slot set to a " { $link model } " instance."
 $nl
 "Some utility words useful in control implementations:"
-{ $subsection gadget-model }
 { $subsection control-value }
 { $subsection set-control-value }
 { $see-also "models" } ;

basis/ui/gadgets/gadgets.factor

@@ -150,7 +150,7 @@ DEFER: relayout
 : invalidate* ( gadget -- )
     \ invalidate* over (>>layout-state)
     dup forget-pref-dim
-    dup gadget-root?
+    dup root?>>
     [ layout-later ] [ parent>> [ relayout ] when* ] if ;
 
 : relayout ( gadget -- )

basis/ui/gadgets/grid-lines/grid-lines-docs.factor

@@ -3,4 +3,4 @@ ui.render ;
 IN: ui.gadgets.grid-lines
 
 HELP: grid-lines
-{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
+{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ;

basis/ui/gadgets/grid-lines/grid-lines.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces opengl opengl.gl sequences
+USING: kernel accessors math namespaces opengl opengl.gl sequences
 math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
 IN: ui.gadgets.grid-lines
 
@@ -10,7 +10,7 @@ C: <grid-lines> grid-lines
 
 SYMBOL: grid-dim
 
-: half-gap grid get grid-gap [ 2/ ] map ; inline
+: half-gap grid get gap>> [ 2/ ] map ; inline
 
 : grid-line-from/to ( orientation point -- from to )
     half-gap v-
@@ -25,7 +25,7 @@ SYMBOL: grid-dim
 M: grid-lines draw-boundary
     origin get [
         -0.5 -0.5 0.0 glTranslated
-        grid-lines-color set-color [
+        color>> set-color [
             dup grid set
             dup rect-dim half-gap v- grid-dim set
             compute-grid

basis/ui/gadgets/grids/grids-docs.factor

@@ -14,9 +14,9 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
 HELP: grid
 { $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
 $nl
-"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
+"The " { $snippet "gap" } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
 $nl
-"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
+"The " { $snippet "fill?" } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
 $nl
 "Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
 $nl