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

basis/alarms/alarms-tests.factor

@@ -1,6 +1,6 @@
-IN: alarms.tests
 USING: alarms alarms.private kernel calendar sequences
 tools.test threads concurrency.count-downs ;
+IN: alarms.tests
 
 [ ] [
     1 <count-down>

basis/alarms/alarms.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators generic init
-kernel math namespaces sequences heaps boxes threads
-quotations assocs math.order ;
+USING: accessors assocs boxes calendar
+combinators.short-circuit fry heaps init kernel math.order
+namespaces quotations threads ;
 IN: alarms
 
 TUPLE: alarm
@@ -21,21 +21,21 @@ SYMBOL: alarm-thread
 
 ERROR: bad-alarm-frequency frequency ;
 : check-alarm ( frequency/f -- frequency/f )
-    dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
+    dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
 
 : <alarm> ( quot time frequency -- alarm )
     check-alarm <box> alarm boa ;
 
 : register-alarm ( alarm -- )
-    dup dup time>> alarms get-global heap-push*
-    swap entry>> >box
+    [ dup time>> alarms get-global heap-push* ]
+    [ entry>> >box ] bi
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
     [ time>> ] dip before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup [ swap interval>> time+ now max ] change-time register-alarm ;
+    dup '[ _ interval>> time+ now max ] change-time register-alarm ;
 
 : call-alarm ( alarm -- )
     [ entry>> box> drop ]

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

@@ -1,6 +1,6 @@
-IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
+IN: alien.c-types.tests
 
 CONSTANT: xyz 123
 

basis/alien/complex/complex.factor

@@ -10,4 +10,4 @@ IN: alien.complex
 ! This overrides the fact that small structures are never returned
 ! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
 "complex-float" c-type t >>return-in-registers? drop
- >>
+>>

basis/alien/complex/functor/functor-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex.functor ;
-IN: alien.complex.functor.tests

basis/alien/destructors/destructors-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.destructors ;
-IN: alien.destructors.tests

basis/alien/fortran/fortran.factor

@@ -357,10 +357,10 @@ M: character-type (<fortran-result>)
 
 : (shuffle-map) ( return parameters -- ret par )
     [
-        fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
+        fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
         letters swap head [ "ret" swap suffix ] map
     ] [
-        [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
+        [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
         [ first2 letters swap head [ "" 2sequence ] with map ] map concat
     ] bi* ;
 

basis/alien/libraries/libraries-tests.factor

@@ -1,5 +1,5 @@
-IN: alien.libraries.tests
 USING: alien.libraries alien.syntax tools.test kernel ;
+IN: alien.libraries.tests
 
 [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
 
@@ -7,4 +7,4 @@ USING: alien.libraries alien.syntax tools.test kernel ;
 
 [ ] [ "doesnotexist" dlopen dlclose ] unit-test
 
-[ "fdasfsf" dll-valid? drop ] must-fail
+[ "fdasfsf" dll-valid? drop ] must-fail

basis/alien/structs/structs-tests.factor

@@ -1,6 +1,6 @@
-IN: alien.structs.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc words vocabs namespaces layouts ;
+IN: alien.structs.tests
 
 C-STRUCT: bar
     { "int" "x" }

basis/alien/syntax/syntax.factor

@@ -31,8 +31,10 @@ SYNTAX: C-ENUM:
     ";" parse-tokens
     [ [ create-in ] dip define-constant ] each-index ;
 
+ERROR: no-such-symbol name library ;
+
 : address-of ( name library -- value )
-    load-library dlsym [ "No such symbol" throw ] unless* ;
+    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
 
 SYNTAX: &:
     scan "c-library" get '[ _ _ address-of ] over push-all ;

basis/ascii/ascii-tests.factor

@@ -10,7 +10,7 @@ IN: ascii.tests
 
 [ 4 ] [
     0 "There are Four Upper Case characters"
-    [ LETTER? [ 1+ ] when ] each
+    [ LETTER? [ 1 + ] when ] each
 ] unit-test
 
 [ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test

basis/base64/base64.factor

@@ -34,7 +34,7 @@ SYMBOL: column
 : write1-lines ( ch -- )
     write1
     column get [
-        1+ [ 76 = [ crlf ] when ]
+        1 + [ 76 = [ crlf ] when ]
         [ 76 mod column set ] bi
     ] when* ;
 
@@ -48,7 +48,7 @@ SYMBOL: column
 
 : encode-pad ( seq n -- )
     [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
-    [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
+    [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
 
 : decode4 ( seq -- )
     [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]

basis/biassocs/biassocs-tests.factor

@@ -1,5 +1,5 @@
+USING: biassocs assocs namespaces tools.test hashtables kernel ;
 IN: biassocs.tests
-USING: biassocs assocs namespaces tools.test ;
 
 <bihash> "h" set
 
@@ -29,4 +29,14 @@ H{ { "a" "A" } { "b" "B" } } "a" set
 
 [ "A" ] [ "a" "b" get at ] unit-test
 
-[ "a" ] [ "A" "b" get value-at ] unit-test
+[ "a" ] [ "A" "b" get value-at ] unit-test
+
+[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
+
+[ ] [ "h" get clone "g" set ] unit-test
+
+[ ] [ 3 4 "g" get set-at ] unit-test
+
+[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
+
+[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test

basis/biassocs/biassocs.factor

@@ -43,4 +43,7 @@ M: biassoc new-assoc
 INSTANCE: biassoc assoc
 
 : >biassoc ( assoc -- biassoc )
-    T{ biassoc } assoc-clone-like ;
+    T{ biassoc } assoc-clone-like ;
+
+M: biassoc clone
+    [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;

basis/binary-search/binary-search-tests.factor

@@ -1,5 +1,5 @@
-IN: binary-search.tests
 USING: binary-search math.order vectors kernel tools.test ;
+IN: binary-search.tests
 
 [ f ] [ 3 { } [ <=> ] with search drop ] unit-test
 [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
@@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
 [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
 [ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
 
-[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
-[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
-[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
-[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -44,33 +44,33 @@ PRIVATE>
 : <bit-array> ( n -- bit-array )
     dup bits>bytes <byte-array> bit-array boa ; inline
 
-M: bit-array length length>> ;
+M: bit-array length length>> ; inline
 
 M: bit-array nth-unsafe
-    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
 
 M: bit-array set-nth-unsafe
     [ >fixnum ] [ underlying>> ] bi*
     [ byte/bit set-bit ] 2keep
-    swap n>byte set-alien-unsigned-1 ;
+    swap n>byte set-alien-unsigned-1 ; inline
 
 GENERIC: clear-bits ( bit-array -- )
 
-M: bit-array clear-bits 0 (set-bits) ;
+M: bit-array clear-bits 0 (set-bits) ; inline
 
 GENERIC: set-bits ( bit-array -- )
 
-M: bit-array set-bits -1 (set-bits) ;
+M: bit-array set-bits -1 (set-bits) ; inline
 
 M: bit-array clone
-    [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+    [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
 
 : >bit-array ( seq -- bit-array )
     T{ bit-array f 0 B{ } } clone-like ; inline
 
-M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
 
-M: bit-array new-sequence drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ; inline
 
 M: bit-array equal?
     over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
@@ -81,7 +81,7 @@ M: bit-array resize
         resize-byte-array
     ] 2bi
     bit-array boa
-    dup clean-up ;
+    dup clean-up ; inline
 
 M: bit-array byte-length length 7 + -3 shift ;
 
@@ -91,10 +91,10 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
     dup 0 = [
         <bit-array>
     ] [
-        [ log2 1+ <bit-array> 0 ] keep
+        [ log2 1 + <bit-array> 0 ] keep
         [ dup 0 = ] [
             [ pick underlying>> pick set-alien-unsigned-1 ] keep
-            [ 1+ ] [ -8 shift ] bi*
+            [ 1 + ] [ -8 shift ] bi*
         ] until 2drop
     ] if ;
 

basis/bit-sets/bit-sets-tests.factor

@@ -1,5 +1,5 @@
-IN: bit-sets.tests
 USING: bit-sets tools.test bit-arrays ;
+IN: bit-sets.tests
 
 [ ?{ t f t f t f } ] [
     ?{ t f f f t f }

basis/bit-vectors/bit-vectors-tests.factor

@@ -1,5 +1,5 @@
-IN: bit-vectors.tests
 USING: tools.test bit-vectors vectors sequences kernel math ;
+IN: bit-vectors.tests
 
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 

basis/bitstreams/bitstreams-tests.factor

@@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 io.streams.byte-array ;
 IN: bitstreams.tests
 
-
 [ BIN: 1111111111 ]
 [
     B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>

basis/bitstreams/bitstreams.factor

@@ -70,7 +70,7 @@ GENERIC: poke ( value n bitstream -- )
     [ get-abp + ] [ set-abp ] bi ; inline
     
 : (align) ( n m -- n' )
-    [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
+    [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
     
 : align ( n bitstream -- )
     [ get-abp swap (align) ] [ set-abp ] bi ; inline

basis/bootstrap/compiler/compiler.factor

@@ -35,83 +35,87 @@ gc
 : compile-unoptimized ( words -- )
     [ optimized? not ] filter compile ;
 
-nl
-"Compiling..." write flush
+"debug-compiler" get [
+    
+    nl
+    "Compiling..." write flush
 
-! Compile a set of words ahead of the full compile.
-! This set of words was determined semi-empirically
-! using the profiler. It improves bootstrap time
-! significantly, because frequenly called words
-! which are also quick to compile are replaced by
-! compiled definitions as soon as possible.
-{
-    not ?
+    ! Compile a set of words ahead of the full compile.
+    ! This set of words was determined semi-empirically
+    ! using the profiler. It improves bootstrap time
+    ! significantly, because frequenly called words
+    ! which are also quick to compile are replaced by
+    ! compiled definitions as soon as possible.
+    {
+        not ?
 
-    2over roll -roll
+        2over roll -roll
 
-    array? hashtable? vector?
-    tuple? sbuf? tombstone?
-    curry? compose? callable?
-    quotation?
+        array? hashtable? vector?
+        tuple? sbuf? tombstone?
+        curry? compose? callable?
+        quotation?
 
-    curry compose uncurry
+        curry compose uncurry
 
-    array-nth set-array-nth length>>
+        array-nth set-array-nth length>>
 
-    wrap probe
+        wrap probe
 
-    namestack*
+        namestack*
 
-    layout-of
-} compile-unoptimized
+        layout-of
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-{
-    bitand bitor bitxor bitnot
-} compile-unoptimized
+    {
+        bitand bitor bitxor bitnot
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-{
-    + 1+ 1- 2/ < <= > >= shift
-} compile-unoptimized
+    {
+        + 2/ < <= > >= shift
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-{
-    new-sequence nth push pop last flip
-} compile-unoptimized
+    {
+        new-sequence nth push pop last flip
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-{
-    hashcode* = equal? assoc-stack (assoc-stack) get set
-} compile-unoptimized
+    {
+        hashcode* = equal? assoc-stack (assoc-stack) get set
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-{
-    memq? split harvest sift cut cut-slice start index clone
-    set-at reverse push-all class number>string string>number
-    like clone-like
-} compile-unoptimized
+    {
+        memq? split harvest sift cut cut-slice start index clone
+        set-at reverse push-all class number>string string>number
+        like clone-like
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-{
-    lines prefix suffix unclip new-assoc update
-    word-prop set-word-prop 1array 2array 3array ?nth
-} compile-unoptimized
+    {
+        lines prefix suffix unclip new-assoc update
+        word-prop set-word-prop 1array 2array 3array ?nth
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-{
-    malloc calloc free memcpy
-} compile-unoptimized
+    {
+        malloc calloc free memcpy
+    } compile-unoptimized
 
-"." write flush
+    "." write flush
 
-vocabs [ words compile-unoptimized "." write flush ] each
+    vocabs [ words compile-unoptimized "." write flush ] each
 
-" done" print flush
+    " done" print flush
+
+] unless

basis/bootstrap/image/image-tests.factor

@@ -1,6 +1,6 @@
-IN: bootstrap.image.tests
 USING: bootstrap.image bootstrap.image.private tools.test
 kernel math ;
+IN: bootstrap.image.tests
 
 [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
 

basis/bootstrap/image/image.factor

@@ -234,7 +234,7 @@ GENERIC: ' ( obj -- ptr )
 
 : bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 
-: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
 
 : bignum>seq ( n -- seq )
     #! n is positive or zero.
@@ -244,7 +244,7 @@ GENERIC: ' ( obj -- ptr )
 
 : emit-bignum ( n -- )
     dup dup 0 < [ neg ] when bignum>seq
-    [ nip length 1+ emit-fixnum ]
+    [ nip length 1 + emit-fixnum ]
     [ drop 0 < 1 0 ? emit ]
     [ nip emit-seq ]
     2tri ;

basis/bootstrap/image/upload/upload.factor

@@ -9,9 +9,9 @@ IN: bootstrap.image.upload
 SYMBOL: upload-images-destination
 
 : destination ( -- dest )
-  upload-images-destination get
-  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
-  or ;
+    upload-images-destination get
+    "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+    or ;
 
 : checksums ( -- temp ) "checksums.txt" temp-file ;
 

basis/bootstrap/math/math.factor

@@ -2,4 +2,4 @@ USING: vocabs vocabs.loader kernel ;
 
 "math.ratios" require
 "math.floats" require
-"math.complex" require
+"math.complex" require

basis/bootstrap/tools/tools.factor

@@ -14,6 +14,7 @@ IN: bootstrap.tools
     "tools.test"
     "tools.time"
     "tools.threads"
+    "tools.deprecation"
     "vocabs.hierarchy"
     "vocabs.refresh"
     "vocabs.refresh.monitor"

basis/boxes/boxes-tests.factor

@@ -1,5 +1,5 @@
-IN: boxes.tests
 USING: boxes namespaces tools.test accessors ;
+IN: boxes.tests
 
 [ ] [ <box> "b" set ] unit-test
 

basis/byte-arrays/hex/hex.factor

@@ -8,4 +8,3 @@ SYNTAX: HEX{
     [ blank? not ] filter
     2 group [ hex> ] B{ } map-as
     parsed ;
-

basis/cache/cache-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test cache ;
-IN: cache.tests

basis/cache/cache.factor

@@ -38,6 +38,6 @@ PRIVATE>
 
 : purge-cache ( cache -- )
     dup max-age>> '[
-        [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
+        [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
         [ values dispose-each ] dip
-    ] change-assoc drop ;
+    ] change-assoc drop ;

basis/cairo/cairo-tests.factor

@@ -1,8 +1,8 @@
-IN: cairo.tests
 USING: cairo tools.test math.rectangles accessors ;
+IN: cairo.tests
 
 [ { 10 20 } ] [
     { 10 20 } [
         { 0 1 } { 3 4 } <rect> fill-rect
     ] make-bitmap-image dim>>
-] unit-test
+] unit-test

basis/calendar/calendar-docs.factor

@@ -27,7 +27,7 @@ HELP: <date>
 } ;
 
 HELP: month-names
-{ $values { "array" array } }
+{ $values { "value" object } }
 { $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." } ;
 

basis/calendar/calendar.factor

@@ -34,25 +34,25 @@ C: <timestamp> timestamp
 : <date> ( year month day -- timestamp )
     0 0 0 gmt-offset-duration <timestamp> ;
 
-ERROR: not-a-month n ;
+ERROR: not-a-month ;
 M: not-a-month summary
     drop "Months are indexed starting at 1" ;
 
 <PRIVATE
 
 : check-month ( n -- n )
-    dup zero? [ not-a-month ] when ;
+    [ not-a-month ] when-zero ;
 
 PRIVATE>
 
-: month-names ( -- array )
+CONSTANT: month-names 
     {
         "January" "February" "March" "April" "May" "June"
         "July" "August" "September" "October" "November" "December"
-    } ;
+    }
 
 : month-name ( n -- string )
-    check-month 1- month-names nth ;
+    check-month 1 - month-names nth ;
 
 CONSTANT: month-abbreviations
     {
@@ -61,7 +61,7 @@ CONSTANT: month-abbreviations
     }
 
 : month-abbreviation ( n -- string )
-    check-month 1- month-abbreviations nth ;
+    check-month 1 - month-abbreviations nth ;
 
 CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
 
@@ -113,7 +113,7 @@ CONSTANT: day-abbreviations3
     100 b * d + 4800 -
     m 10 /i + m 3 +
     12 m 10 /i * -
-    e 153 m * 2 + 5 /i - 1+ ;
+    e 153 m * 2 + 5 /i - 1 + ;
 
 GENERIC: easter ( obj -- obj' )
 
@@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
     { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
     [ 3 >>month 1 >>day ] when ;
 
-: unless-zero ( n quot -- )
-    [ dup zero? [ drop ] ] dip if ; inline
-
 M: integer +year ( timestamp n -- timestamp )
     [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
 
@@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
     [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
 
 : months/years ( n -- months years )
-    12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
+    12 /rem [ 1 - 12 ] when-zero swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
     [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
@@ -371,10 +368,10 @@ M: duration time-
     #! http://web.textfiles.com/computers/formulas.txt
     #! good for any date since October 15, 1582
     [
-        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
+        dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
         [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
-        [ 1+ 3 * 5 /i + ] keep 2 * +
-    ] dip 1+ + 7 mod ;
+        [ 1 + 3 * 5 /i + ] keep 2 * +
+    ] dip 1 + + 7 mod ;
 
 GENERIC: days-in-year ( obj -- n )
 
@@ -395,7 +392,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
     year leap-year? [
         year month day <date>
         year 3 1 <date>
-        after=? [ 1+ ] when
+        after=? [ 1 + ] when
     ] when ;
 
 : day-of-year ( timestamp -- n )

basis/calendar/format/format.factor

@@ -68,8 +68,8 @@ M: array month. ( pair -- )
     [ (days-in-month) day-abbreviations2 " " join print ] 2tri
     over "   " <repetition> concat write
     [
-        [ 1+ day. ] keep
-        1+ + 7 mod zero? [ nl ] [ bl ] if
+        [ 1 + day. ] keep
+        1 + + 7 mod zero? [ nl ] [ bl ] if
     ] with each nl ;
 
 M: timestamp month. ( timestamp -- )
@@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
 GENERIC: year. ( obj -- )
 
 M: integer year. ( n -- )
-    12 [ 1+ 2array month. nl ] with each ;
+    12 [ 1 + 2array month. nl ] with each ;
 
 M: timestamp year. ( timestamp -- )
     year>> year. ;
@@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
 
 : read-rfc3339-seconds ( s -- s' ch )
     "+-Z" read-until [
-        [ string>number ] [ length 10 swap ^ ] bi / +
+        [ string>number ] [ length 10^ ] bi / +
     ] dip ;
 
 : (rfc3339>timestamp) ( -- timestamp )
@@ -201,7 +201,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token day-abbreviations3 member? check-timestamp drop
         read1 CHAR: \s assert=
         read-sp checked-number >>day
-        read-sp month-abbreviations index 1+ check-timestamp >>month
+        read-sp month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -220,7 +220,7 @@ ERROR: invalid-timestamp-format ;
         "," read-token check-day-name
         read1 CHAR: \s assert=
         "-" read-token checked-number >>day
-        "-" read-token month-abbreviations index 1+ check-timestamp >>month
+        "-" read-token month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>year
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute
@@ -233,7 +233,7 @@ ERROR: invalid-timestamp-format ;
 : (cookie-string>timestamp-2) ( -- timestamp )
     timestamp new
         read-sp check-day-name
-        read-sp month-abbreviations index 1+ check-timestamp >>month
+        read-sp month-abbreviations index 1 + check-timestamp >>month
         read-sp checked-number >>day
         ":" read-token checked-number >>hour
         ":" read-token checked-number >>minute

basis/channels/examples/examples.factor

@@ -7,7 +7,7 @@ locals sequences ;
 IN: channels.examples
 
 : (counter) ( channel n -- )
-    [ swap to ] 2keep 1+ (counter) ;
+    [ swap to ] 2keep 1 + (counter) ;
     
 : counter ( channel -- )
     2 (counter) ;    

basis/checksums/fnv1/fnv1.factor

@@ -1,9 +1,7 @@
 ! Copyright (C) 2009 Alaric Snell-Pym
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: checksums classes.singleton kernel math math.ranges
 math.vectors sequences ;
-
 IN: checksums.fnv1
 
 SINGLETON: fnv1-32

basis/checksums/md5/md5-tests.factor

@@ -1,6 +1,8 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays checksums checksums.md5 io.encodings.binary
 io.streams.byte-array kernel math namespaces tools.test ;
-
+IN: checksums.md5.tests 
 
 [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
 [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test

basis/circular/circular-tests.factor

@@ -2,6 +2,7 @@
 ! See http;//factorcode.org/license.txt for BSD license
 USING: arrays kernel tools.test sequences sequences.private
 circular strings ;
+IN: circular.tests
 
 [ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
 [ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test

basis/circular/circular.factor

@@ -51,7 +51,7 @@ PRIVATE>
 
 : push-growing-circular ( elt circular -- )
     dup full? [ push-circular ]
-    [ [ 1+ ] change-length set-last ] if ;
+    [ [ 1 + ] change-length set-last ] if ;
 
 : <growing-circular> ( capacity -- growing-circular )
     { } new-sequence 0 0 growing-circular boa ;

basis/cocoa/callbacks/callbacks.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Kevin Reid.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: cocoa.callbacks
 USING: assocs kernel namespaces cocoa cocoa.classes
 cocoa.subclassing debugger ;
+IN: cocoa.callbacks
 
 SYMBOL: callbacks
 

basis/cocoa/cocoa-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.tests
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
 compiler kernel namespaces cocoa.classes tools.test memory
 compiler.units math core-graphics.types ;
+IN: cocoa.tests
 
 CLASS: {
     { +superclass+ "NSObject" }

basis/cocoa/messages/messages.factor

@@ -172,7 +172,7 @@ ERROR: no-objc-type name ;
     [ ] [ no-objc-type ] ?if ;
 
 : (parse-objc-type) ( i string -- ctype )
-    [ [ 1+ ] dip ] [ nth ] 2bi {
+    [ [ 1 + ] dip ] [ nth ] 2bi {
         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
         { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
         { [ dup CHAR: { = ] [ drop objc-struct-type ] }

basis/cocoa/plists/plists-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.plists.tests
 USING: tools.test cocoa.plists colors kernel hashtables
 core-foundation.utilities core-foundation destructors
 assocs cocoa.enumeration ;
+IN: cocoa.plists.tests
 
 [
     [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
@@ -37,4 +37,4 @@ assocs cocoa.enumeration ;
     [ 3.5 ] [
         3.5 >cf &CFRelease plist>
     ] unit-test
-] with-destructors
+] with-destructors

basis/colors/hsv/hsv-tests.factor

@@ -1,5 +1,5 @@
-IN: colors.hsv.tests
 USING: accessors kernel colors colors.hsv tools.test math ;
+IN: colors.hsv.tests
 
 : hsv>rgb ( h s v -- r g b )
     [ 360 * ] 2dip
@@ -25,4 +25,4 @@ USING: accessors kernel colors colors.hsv tools.test math ;
 [ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
 [ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
 
-[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
+[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test

basis/columns/columns-tests.factor

@@ -1,5 +1,5 @@
-IN: columns.tests
 USING: columns sequences kernel namespaces arrays tools.test math ;
+IN: columns.tests
 
 ! Columns
 { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

basis/combinators/short-circuit/smart/smart-tests.factor

@@ -1,32 +1,18 @@
-
 USING: kernel math tools.test combinators.short-circuit.smart ;
-
 IN: combinators.short-circuit.smart.tests
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] unit-test
+[ t ] [ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] unit-test
+[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
 
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
+[ f ] [       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          unit-test
+[ f ] [ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
 
-[       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] must-be-t
-[ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
+[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       unit-test
 
-[       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          must-be-f
-[ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       must-be-f
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
-
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       must-be-t
-
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  must-be-t
-
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  unit-test
 
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test

basis/combinators/short-circuit/smart/smart.factor

@@ -1,13 +1,15 @@
-USING: kernel sequences math stack-checker effects accessors macros
-fry combinators.short-circuit ;
+USING: kernel sequences math stack-checker effects accessors
+macros fry combinators.short-circuit ;
 IN: combinators.short-circuit.smart
 
 <PRIVATE
 
+ERROR: cannot-determine-arity ;
+
 : arity ( quots -- n )
     first infer
-    dup terminated?>> [ "Cannot determine arity" throw ] when
-    effect-height neg 1+ ;
+    dup terminated?>> [ cannot-determine-arity ] when
+    effect-height neg 1 + ;
 
 PRIVATE>
 

basis/combinators/smart/smart-docs.factor

@@ -28,7 +28,7 @@ HELP: output>array
     { $example
         <" USING: combinators combinators.smart math prettyprint ;
 9 [
-    { [ 1- ] [ 1+ ] [ sq ] } cleave
+    { [ 1 - ] [ 1 + ] [ sq ] } cleave
 ] output>array .">
     "{ 8 10 81 }"
     }
@@ -71,7 +71,7 @@ HELP: sum-outputs
 { $examples
     { $example
         "USING: combinators.smart kernel math prettyprint ;"
-        "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+        "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
         "20"
     }
 } ;

basis/combinators/smart/smart-tests.factor

@@ -4,7 +4,7 @@ USING: tools.test combinators.smart math kernel accessors ;
 IN: combinators.smart.tests
 
 : test-bi ( -- 9 11 )
-    10 [ 1- ] [ 1+ ] bi ;
+    10 [ 1 - ] [ 1 + ] bi ;
 
 [ [ test-bi ] output>array ] must-infer
 [ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
@@ -46,4 +46,4 @@ IN: combinators.smart.tests
 
 [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
 
-[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
+[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -1 +0,0 @@
-IN: compiler.cfg.alias-analysis.tests

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -144,7 +144,7 @@ ERROR: vreg-has-no-slots vreg ;
 SYMBOL: ac-counter
 
 : next-ac ( -- n )
-    ac-counter [ dup 1+ ] change ;
+    ac-counter [ dup 1 + ] change ;
 
 ! Alias class for objects which are loaded from the data stack
 ! or other object slots. We pessimistically assume that they
@@ -285,4 +285,4 @@ M: insn eliminate-dead-stores* ;
     eliminate-dead-stores ;
 
 : alias-analysis ( cfg -- cfg' )
-    [ alias-analysis-step ] local-optimization ;
+    [ alias-analysis-step ] local-optimization ;

basis/compiler/cfg/builder/builder-tests.factor

@@ -1,11 +1,11 @@
-IN: compiler.cfg.builder.tests
 USING: tools.test kernel sequences words sequences.private fry
 prettyprint alien alien.accessors math.private compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
 compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
 compiler.cfg arrays locals byte-arrays kernel.private math
 slots.private vectors sbufs strings math.partial-dispatch
-strings.private ;
+strings.private accessors compiler.cfg.instructions ;
+IN: compiler.cfg.builder.tests
 
 ! Just ensure that various CFGs build correctly.
 : unit-test-cfg ( quot -- )
@@ -157,3 +157,26 @@ strings.private ;
     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
 ] each
+
+: contains-insn? ( quot insn-check -- ? )
+    [ test-mr [ instructions>> ] map ] dip
+    '[ _ any? ] any? ; inline
+
+[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ t ] [
+    [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ t ] [
+    [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ f ] [
+    [ { byte-array fixnum } declare set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test

basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor

@@ -5,7 +5,7 @@ namespaces functors compiler.cfg.rpo compiler.cfg.utilities
 compiler.cfg.predecessors compiler.cfg ;
 IN: compiler.cfg.dataflow-analysis
 
-GENERIC: join-sets ( sets dfa -- set )
+GENERIC: join-sets ( sets bb dfa -- set )
 GENERIC: transfer-set ( in-set bb dfa -- out-set )
 GENERIC: block-order ( cfg dfa -- bbs )
 GENERIC: successors ( bb dfa -- seq )
@@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
 M: kill-block compute-in-set 3drop f ;
 
 M:: basic-block compute-in-set ( bb out-sets dfa -- set )
-    bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+    ! Only consider initialized sets.
+    bb dfa predecessors
+    [ out-sets key? ] filter
+    [ out-sets at ] map
+    bb dfa join-sets ;
 
 :: update-in-set ( bb in-sets out-sets dfa -- ? )
     bb out-sets dfa compute-in-set
@@ -56,7 +60,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
     in-sets
     out-sets ; inline
 
-M: dataflow-analysis join-sets drop assoc-refine ;
+M: dataflow-analysis join-sets 2drop assoc-refine ;
 
 FUNCTOR: define-analysis ( name -- )
 

basis/compiler/cfg/def-use/def-use-tests.factor

@@ -8,6 +8,7 @@ compiler.cfg
 compiler.cfg.debugger
 compiler.cfg.instructions
 compiler.cfg.registers ;
+IN: compiler.cfg.def-use.tests
 
 V{
     T{ ##peek f 0 D 0 }

basis/compiler/cfg/dominance/dominance-tests.factor

@@ -1,7 +1,7 @@
-IN: compiler.cfg.dominance.tests
 USING: tools.test sequences vectors namespaces kernel accessors assocs sets
 math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
 compiler.cfg.predecessors ;
+IN: compiler.cfg.dominance.tests
 
 : test-dominance ( -- )
     cfg new 0 get >>entry

basis/compiler/cfg/gc-checks/gc-checks-tests.factor

@@ -1,8 +1,8 @@
-IN: compiler.cfg.gc-checks.tests
 USING: compiler.cfg.gc-checks compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
 namespaces accessors sequences ;
+IN: compiler.cfg.gc-checks.tests
 
 : test-gc-checks ( -- )
     H{ } clone representations set
@@ -23,4 +23,4 @@ V{
 
 [ ] [ test-gc-checks ] unit-test
 
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
+[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -8,11 +8,11 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots ( regs obj class -- )
-    '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
+    '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
 
 : emit-simple-allot ( node -- )
     [ in-d>> length ] [ node-output-infos first class>> ] bi
-    [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+    [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
     [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 
 : tuple-slot-regs ( layout -- vregs )

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -1,9 +1,9 @@
-IN: compiler.cfg.linear-scan.resolve.tests
 USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
 accessors
 compiler.cfg
 compiler.cfg.instructions cpu.architecture make sequences
 compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
@@ -64,4 +64,4 @@ H{ } clone spill-temps set
             T{ _reload { dst 0 } { rep int-rep } { n 8 } }
         }
     } member?
-] unit-test
+] unit-test

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -65,7 +65,7 @@ SYMBOL: temp
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
-        mapping-instructions <simple-block> insert-basic-block
+        mapping-instructions insert-simple-basic-block
         cfg get cfg-changed drop
     ] if ;
 

basis/compiler/cfg/linearization/linearization-tests.factor

@@ -1,4 +0,0 @@
-IN: compiler.cfg.linearization.tests
-USING: compiler.cfg.linearization tools.test ;
-
-

basis/compiler/cfg/liveness/liveness.factor

@@ -28,4 +28,4 @@ M: live-analysis transfer-set
     drop instructions>> transfer-liveness ;
 
 M: live-analysis join-sets
-    drop assoc-combine ;
+    2drop assoc-combine ;

basis/compiler/cfg/loop-detection/loop-detection-tests.factor

@@ -1,8 +1,8 @@
-IN: compiler.cfg.loop-detection.tests
 USING: compiler.cfg compiler.cfg.loop-detection
 compiler.cfg.predecessors
 compiler.cfg.debugger
 tools.test kernel namespaces accessors ;
+IN: compiler.cfg.loop-detection.tests
 
 V{ } 0 test-bb
 V{ } 1 test-bb

basis/compiler/cfg/loop-detection/loop-detection.factor

@@ -6,10 +6,10 @@ IN: compiler.cfg.loop-detection
 
 TUPLE: natural-loop header index ends blocks ;
 
-<PRIVATE
-
 SYMBOL: loops
 
+<PRIVATE
+
 : <natural-loop> ( header index -- loop )
     H{ } clone H{ } clone natural-loop boa ;
 
@@ -80,4 +80,4 @@ PRIVATE>
 
 : needs-loops ( cfg -- cfg' )
     needs-predecessors
-    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
+    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -45,7 +45,7 @@ ERROR: bad-peek dst loc ;
     ! computing anything.
     2dup [ kill-block? ] both? [ 2drop ] [
         2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
-        [ 2drop ] [ <simple-block> insert-basic-block ] if-empty
+        [ 2drop ] [ insert-simple-basic-block ] if-empty
     ] if ;
 
 : visit-block ( bb -- )
@@ -56,4 +56,4 @@ ERROR: bad-peek dst loc ;
 
     dup [ visit-block ] each-basic-block
 
-    cfg-changed ;
+    cfg-changed ;

basis/compiler/cfg/stacks/global/global.factor

@@ -21,7 +21,7 @@ BACKWARD-ANALYSIS: live
 
 M: live-analysis transfer-set drop transfer-peeked-locs ;
 
-M: live-analysis join-sets drop assoc-combine ;
+M: live-analysis join-sets 2drop assoc-combine ;
 
 ! A stack location is available at a location if all paths from
 ! the entry block to the location load the location into a
@@ -56,4 +56,4 @@ M: dead-analysis transfer-set
         [ compute-dead-sets ]
         [ compute-avail-sets ]
         [ ]
-    } cleave ;
+    } cleave ;

basis/compiler/cfg/stacks/local/local.factor

@@ -69,18 +69,11 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
 
 : peek-loc ( loc -- vreg )
     translate-local-loc
-    dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
-    dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
+    dup replace-mapping get at
+    [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
 
 : replace-loc ( vreg loc -- )
-    translate-local-loc
-    2dup loc>vreg =
-    [ nip replace-mapping get delete-at ]
-    [
-        [ local-replace-set get conjoin ]
-        [ replace-mapping get set-at ]
-        bi
-    ] if ;
+    translate-local-loc replace-mapping get set-at ;
 
 : compute-local-kill-set ( -- assoc )
     basic-block get current-height get
@@ -90,13 +83,17 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
 
 : begin-local-analysis ( -- )
     H{ } clone local-peek-set set
-    H{ } clone local-replace-set set
     H{ } clone replace-mapping set
     current-height get
     [ 0 >>emit-d 0 >>emit-r drop ]
     [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
 
+: remove-redundant-replaces ( -- )
+    replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
+    [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
+
 : end-local-analysis ( -- )
+    remove-redundant-replaces
     emit-changes
     basic-block get {
         [ [ local-peek-set get ] dip peek-sets get set-at ]

basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor

@@ -1,8 +1,8 @@
-IN: compiler.cfg.stacks.uninitialized.tests
 USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
 namespaces accessors sequences ;
+IN: compiler.cfg.stacks.uninitialized.tests
 
 : test-uninitialized ( -- )
     cfg new 0 get >>entry

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -65,7 +65,7 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
     drop [ prepare ] dip visit-block finish ;
 
 M: uninitialized-analysis join-sets ( sets analysis -- pair )
-    drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
+    2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
 
 : uninitialized-locs ( bb -- locs )
     uninitialized-in dup [
@@ -73,4 +73,4 @@ M: uninitialized-analysis join-sets ( sets analysis -- pair )
         [ [ <ds-loc> ] (uninitialized-locs) ]
         [ [ <rs-loc> ] (uninitialized-locs) ]
         bi* append
-    ] when ;
+    ] when ;

basis/compiler/cfg/two-operand/two-operand-tests.factor

@@ -1,6 +1,6 @@
-IN: compiler.cfg.two-operand.tests
 USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
 compiler.cfg.registers cpu.architecture namespaces tools.test ;
+IN: compiler.cfg.two-operand.tests
 
 3 vreg-counter set-global
 

basis/compiler/cfg/utilities/utilities.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs combinators combinators.short-circuit
 cpu.architecture kernel layouts locals make math namespaces sequences
 sets vectors fry compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo ;
+compiler.cfg.rpo arrays ;
 IN: compiler.cfg.utilities
 
 PREDICATE: kill-block < basic-block
@@ -37,16 +37,16 @@ SYMBOL: visited
 : skip-empty-blocks ( bb -- bb' )
     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
-:: insert-basic-block ( from to bb -- )
-    bb from 1vector >>predecessors drop
+:: insert-basic-block ( froms to bb -- )
+    bb froms V{ } like >>predecessors drop
     bb to 1vector >>successors drop
-    to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
-    from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+    to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
+    froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
 
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[
         building get pop
-        @
+        [ @ ] dip
         ,
     ] with-variable ; inline
 
@@ -56,6 +56,9 @@ SYMBOL: visited
     \ ##branch new-insn over push
     >>instructions ;
 
+: insert-simple-basic-block ( from to insns -- )
+    [ 1vector ] 2dip <simple-block> insert-basic-block ;
+
 : has-phis? ( bb -- ? )
     instructions>> first ##phi? ;
 

basis/compiler/cfg/write-barrier/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

@@ -1,7 +1,16 @@
-USING: compiler.cfg.write-barrier compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test vectors compiler.cfg kernel accessors
-compiler.cfg.utilities ;
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs compiler.cfg
+compiler.cfg.alias-analysis compiler.cfg.block-joining
+compiler.cfg.branch-splitting compiler.cfg.copy-prop
+compiler.cfg.dce compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.loop-detection
+compiler.cfg.registers compiler.cfg.ssa.construction
+compiler.cfg.tco compiler.cfg.useless-conditionals
+compiler.cfg.utilities compiler.cfg.value-numbering
+compiler.cfg.write-barrier cpu.architecture kernel
+kernel.private math namespaces sequences sequences.private
+tools.test vectors ;
 IN: compiler.cfg.write-barrier.tests
 
 : test-write-barrier ( insns -- insns )
@@ -70,3 +79,112 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##write-barrier f 19 30 3 }
     } test-write-barrier
 ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+    T{ ##allot f 1 }
+} 1 test-bb
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##allot f 1 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+    T{ ##allot }
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+    T{ ##allot }
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+    T{ ##allot }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 3 test-bb
+2 get 3 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 3 get instructions>> ] unit-test
+
+: reverse-here' ( seq -- )
+    { array } declare
+    [ length 2/ iota ] [ length ] [ ] tri
+    [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
+
+: write-barrier-stats ( word -- cfg )
+    test-cfg first [
+        optimize-tail-calls
+        delete-useless-conditionals
+        split-branches
+        join-blocks
+        construct-ssa
+        alias-analysis
+        value-numbering
+        copy-propagation
+        eliminate-dead-code
+        eliminate-write-barriers
+    ] with-cfg
+    post-order>> write-barriers
+    [ [ loop-nesting-at ] [ length ] bi* ] assoc-map ;
+
+[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test

basis/compiler/cfg/write-barrier/write-barrier.factor

@@ -1,7 +1,16 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces assocs sets sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+fry combinators.short-circuit locals make arrays
+compiler.cfg
+compiler.cfg.dominance
+compiler.cfg.predecessors
+compiler.cfg.loop-detection
+compiler.cfg.rpo
+compiler.cfg.instructions 
+compiler.cfg.registers
+compiler.cfg.dataflow-analysis 
+compiler.cfg.utilities ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -19,21 +28,112 @@ M: ##allot eliminate-write-barrier
     dst>> safe get conjoin t ;
 
 M: ##write-barrier eliminate-write-barrier
-    src>> dup [ safe get key? not ] [ mutated get key? ] bi and
+    src>> dup safe get key? not
     [ safe get conjoin t ] [ drop f ] if ;
 
-M: ##set-slot eliminate-write-barrier
-    obj>> mutated get conjoin t ;
-
-M: ##set-slot-imm eliminate-write-barrier
-    obj>> mutated get conjoin t ;
-
 M: insn eliminate-write-barrier drop t ;
 
+! This doesn't actually benefit from being a dataflow analysis
+! might as well be dominator-based
+! Dealing with phi functions would help, though
+FORWARD-ANALYSIS: safe
+
+: has-allocation? ( bb -- ? )
+    instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
+
+M: safe-analysis transfer-set
+    drop [ H{ } assoc-clone-like safe set ] dip
+    instructions>> [
+        eliminate-write-barrier drop
+    ] each safe get ;
+
+M: safe-analysis join-sets
+    drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
+
 : write-barriers-step ( bb -- )
-    H{ } clone safe set
-    H{ } clone mutated set
+    dup safe-in H{ } assoc-clone-like safe set
     instructions>> [ eliminate-write-barrier ] filter-here ;
 
+GENERIC: remove-dead-barrier ( insn -- ? )
+
+M: ##write-barrier remove-dead-barrier
+    src>> mutated get key? ;
+
+M: ##set-slot remove-dead-barrier
+    obj>> mutated get conjoin t ;
+
+M: ##set-slot-imm remove-dead-barrier
+    obj>> mutated get conjoin t ;
+
+M: insn remove-dead-barrier drop t ;
+
+: remove-dead-barriers ( bb -- )
+    H{ } clone mutated set
+    instructions>> [ remove-dead-barrier ] filter-here ;
+
+! Availability of slot
+! Anticipation of this and set-slot would help too, maybe later
+FORWARD-ANALYSIS: slot
+
+UNION: access ##read ##write ;
+
+M: slot-analysis transfer-set
+    drop [ H{ } assoc-clone-like ] dip
+    instructions>> over '[
+        dup access? [
+            obj>> _ conjoin
+        ] [ drop ] if
+    ] each ;
+
+: slot-available? ( vreg bb -- ? )
+    slot-in key? ;
+
+: make-barriers ( vregs -- bb )
+    [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
+
+: emit-barriers ( vregs loop -- )
+    swap [
+        [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
+        [ header>> ] bi
+    ] [ make-barriers ] bi*
+    insert-basic-block ;
+
+: write-barriers ( bbs -- bb=>barriers )
+    [
+        dup instructions>>
+        [ ##write-barrier? ] filter
+        [ src>> ] map
+    ] { } map>assoc
+    [ nip empty? not ] assoc-filter ;
+
+: filter-dominant ( bb=>barriers bbs -- barriers )
+    '[ drop _ [ dominates? ] with all? ] assoc-filter
+    values concat prune ;
+
+: dominant-write-barriers ( loop -- vregs )
+    [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
+
+: safe-loops ( -- loops )
+    loops get values
+    [ blocks>> keys [ has-allocation? not ] all? ] filter ;
+
+:: insert-extra-barriers ( cfg -- )
+    safe-loops [| loop |
+        cfg needs-dominance needs-predecessors drop
+        loop dominant-write-barriers
+        loop header>> '[ _ slot-available? ] filter
+        [ loop emit-barriers cfg cfg-changed drop ] unless-empty
+    ] each ;
+
+: contains-write-barrier? ( cfg -- ? )
+    post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;
+
 : eliminate-write-barriers ( cfg -- cfg' )
-    dup [ write-barriers-step ] each-basic-block ;
+    dup contains-write-barrier? [
+        needs-loops
+        dup [ remove-dead-barriers ] each-basic-block
+        dup compute-slot-sets
+        dup insert-extra-barriers
+        dup compute-safe-sets
+        dup [ write-barriers-step ] each-basic-block
+    ] when ;

basis/compiler/codegen/codegen-tests.factor

@@ -1,6 +1,6 @@
-IN: compiler.codegen.tests
 USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
 compiler.constants ;
+IN: compiler.codegen.tests
 
 [ ] [ [ ] with-fixup drop ] unit-test
 [ ] [ [ \ + %call ] with-fixup drop ] unit-test

basis/compiler/compiler.factor

@@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
     } cond ;
 
 : optimize? ( word -- ? )
-    { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
+    single-generic? not ;
 
 : contains-breakpoints? ( -- ? )
     dependencies get keys [ "break?" word-prop ] any? ;

basis/compiler/tests/alien.factor

@@ -395,7 +395,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 
 : callback-9 ( -- callback )
     "int" { "int" "int" "int" } "cdecl" [
-        + + 1+
+        + + 1 +
     ] alien-callback ;
 
 FUNCTION: void ffi_test_36_point_5 ( ) ;
@@ -599,4 +599,4 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 [ 123 ] [
     "bool-field-test" <c-object> 123 over set-bool-field-test-parents
     ffi_test_48
-] unit-test
+] unit-test

basis/compiler/tests/call-effect.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.call-effect
 USING: tools.test combinators generic.single sequences kernel ;
+IN: compiler.tests.call-effect
 
 : execute-ic-test ( a b -- c ) execute( a -- c ) ;
 
@@ -11,4 +11,4 @@ USING: tools.test combinators generic.single sequences kernel ;
 [ ] [ [ ] call-test ] unit-test
 [ ] [ f [ drop ] curry call-test ] unit-test
 [ ] [ [ ] [ ] compose call-test ] unit-test
-[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with

basis/compiler/tests/float.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.float
 USING: compiler.units compiler kernel kernel.private memory math
 math.private tools.test math.floats.private ;
+IN: compiler.tests.float
 
 [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
 [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test

basis/compiler/tests/generic.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.generic
 USING: tools.test math kernel compiler.units definitions ;
+IN: compiler.tests.generic
 
 GENERIC: bad ( -- )
 M: integer bad ;
@@ -8,4 +8,4 @@ M: object bad ;
 [ 0 bad ] must-fail
 [ "" bad ] must-fail
 
-[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test

basis/compiler/tests/optimizer.factor

@@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions ;
+compiler definitions generic.single ;
 IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
@@ -67,7 +67,7 @@ TUPLE: pred-test ;
 [ 3 ] [ t bad-kill-2 ] unit-test
 
 ! regression
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive
+: (the-test) ( x -- y ) dup 0 > [ 1 - (the-test) ] when ; inline recursive
 : the-test ( -- x y ) 2 dup (the-test) ;
 
 [ 2 0 ] [ the-test ] unit-test
@@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * )
 
 ! regression
 : branch-fold-regression-0 ( m -- n )
-    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive
+    t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive
 
 : branch-fold-regression-1 ( -- m )
     10 branch-fold-regression-0 ;
@@ -348,12 +348,12 @@ TUPLE: some-tuple x ;
 
 [ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
 
-[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test
 
 : deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
 
@@ -382,7 +382,7 @@ DEFER: loop-bbb
 ! Type inference issue
 [ 4 3 ] [
     1 >bignum 2 >bignum
-    [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
+    [ { bignum integer } declare [ shift ] keep 1 + ] compile-call
 ] unit-test
 
 : broken-declaration ( -- ) \ + declare ;
@@ -422,4 +422,7 @@ M: object bad-dispatch-position-test* ;
         \ bad-dispatch-position-test forget
         \ bad-dispatch-position-test* forget
     ] with-compilation-unit
-] unit-test
+] unit-test
+
+! Not sure if I want to fix this...
+! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with

basis/compiler/tests/peg-regression-2.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.peg-regression-2
 USING: peg.ebnf strings tools.test ;
+IN: compiler.tests.peg-regression-2
 
 GENERIC: <times> ( times -- term' )
 M: string <times> ;

basis/compiler/tests/pic-problem-1.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.pic-problem-1
 USING: kernel sequences prettyprint memory tools.test ;
+IN: compiler.tests.pic-problem-1
 
 TUPLE: x ;
 
@@ -11,4 +11,4 @@ INSTANCE: x sequence
 
 CONSTANT: blah T{ x }
 
-[ T{ x } ] [ blah ] unit-test
+[ T{ x } ] [ blah ] unit-test

basis/compiler/tests/redefine0.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.redefine0
 USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
 namespaces macros assocs ;
+IN: compiler.tests.redefine0
 
 ! Test ripple-up behavior
 : test-1 ( -- a ) 3 ;

basis/compiler/tests/redefine15.factor

@@ -11,7 +11,7 @@ DEFER: word-1
 
 : word-3 ( a -- b ) 1 + ;
 
-: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;
+: word-4 ( a -- b c ) 0 swap word-3 swap 1 + ;
 
 [ 1 1 ] [ 0 word-4 ] unit-test
 

basis/compiler/tests/redefine16.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.redefine16
 USING: eval tools.test definitions words compiler.units
 quotations stack-checker ;
+IN: compiler.tests.redefine16
 
 [ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
 

basis/compiler/tests/redefine17.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.redefine17
 USING: tools.test classes.mixin compiler.units arrays kernel.private
 strings sequences vocabs definitions kernel ;
+IN: compiler.tests.redefine17
 
 << "compiler.tests.redefine17" words forget-all >>
 

basis/compiler/tests/redefine2.factor

@@ -1,7 +1,7 @@
-IN: compiler.tests.redefine2
 USING: compiler compiler.units tools.test math parser kernel
 sequences sequences.private classes.mixin generic definitions
 arrays words assocs eval words.symbol ;
+IN: compiler.tests.redefine2
 
 DEFER: redefine2-test
 

basis/compiler/tests/redefine3.factor

@@ -1,15 +1,15 @@
-IN: compiler.tests.redefine3
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
 definitions arrays words assocs eval ;
+IN: compiler.tests.redefine3
 
 GENERIC: sheeple ( obj -- x )
 
-M: object sheeple drop "sheeple" ;
+M: object sheeple drop "sheeple" ; inline
 
 MIXIN: empty-mixin
 
-M: empty-mixin sheeple drop "wake up" ;
+M: empty-mixin sheeple drop "wake up" ; inline
 
 : sheeple-test ( -- string ) { } sheeple ;
 

basis/compiler/tests/redefine4.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.redefine4
 USING: io.streams.string kernel tools.test eval ;
+IN: compiler.tests.redefine4
 
 : declaration-test-1 ( -- a ) 3 ; flushable
 

basis/compiler/tests/reload.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.reload
 USE: vocabs.loader
+IN: compiler.tests.reload
 
 ! "parser" reload
 ! "sequences" reload

basis/compiler/tests/stack-trace.factor

@@ -1,7 +1,7 @@
-IN: compiler.tests.stack-trace
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
 words splitting grouping sorting accessors ;
+IN: compiler.tests.stack-trace
 
 : symbolic-stack-trace ( -- newseq )
     error-continuation get call>> callstack>array
@@ -13,7 +13,7 @@ words splitting grouping sorting accessors ;
 [ baz ] [ 3 = ] must-fail-with
 [ t ] [
     symbolic-stack-trace
-    [ word? ] filter
+    2 head*
     { baz bar foo } tail?
 ] unit-test
 
@@ -24,7 +24,7 @@ words splitting grouping sorting accessors ;
 [ t ] [
     [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
 ] unit-test
-    
+
 [ t f ] [
     [ { "hi" } bleh ] ignore-errors
     \ + stack-trace-any?

basis/compiler/tests/tuples.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.tuples
 USING: kernel tools.test compiler.units compiler ;
+IN: compiler.tests.tuples
 
 TUPLE: color red green blue ;
 

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

@@ -1,6 +1,6 @@
-IN: compiler.tree.builder.tests
 USING: compiler.tree.builder tools.test sequences kernel
 compiler.tree stack-checker stack-checker.errors ;
+IN: compiler.tree.builder.tests
 
 : inline-recursive ( -- ) inline-recursive ; inline recursive
 

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

@@ -1,4 +0,0 @@
-IN: compiler.tree.checker.tests
-USING: compiler.tree.checker tools.test ;
-
-

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

@@ -1,4 +1,3 @@
-IN: compiler.tree.cleanup.tests
 USING: tools.test kernel.private kernel arrays sequences
 math.private math generic words quotations alien alien.c-types
 strings sbufs sequences.private slots.private combinators
@@ -17,6 +16,7 @@ compiler.tree.propagation
 compiler.tree.propagation.info
 compiler.tree.checker
 compiler.tree.debugger ;
+IN: compiler.tree.cleanup.tests
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 
@@ -41,13 +41,13 @@ compiler.tree.debugger ;
 
 GENERIC: mynot ( x -- y )
 
-M: f mynot drop t ;
+M: f mynot drop t ; inline
 
-M: object mynot drop f ;
+M: object mynot drop f ; inline
 
 GENERIC: detect-f ( x -- y )
 
-M: f detect-f ;
+M: f detect-f ; inline
 
 [ t ] [
     [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
@@ -55,9 +55,9 @@ M: f detect-f ;
 
 GENERIC: xyz ( n -- n )
 
-M: integer xyz ;
+M: integer xyz ; inline
 
-M: object xyz ;
+M: object xyz ; inline
 
 [ t ] [
     [ { integer } declare xyz ] \ xyz inlined?
@@ -88,7 +88,7 @@ M: object xyz ;
     2over dup xyz drop >= [
         3drop
     ] [
-        [ swap [ call 1+ ] dip ] keep (i-repeat)
+        [ swap [ call 1 + ] dip ] keep (i-repeat)
     ] if ; inline recursive
 
 : i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
@@ -115,10 +115,6 @@ M: object xyz ;
     [ { fixnum } declare [ ] times ] \ >= inlined?
 ] unit-test
 
-[ t ] [
-    [ { fixnum } declare [ ] times ] \ 1+ inlined?
-] unit-test
-
 [ t ] [
     [ { fixnum } declare [ ] times ] \ + inlined?
 ] unit-test
@@ -172,19 +168,6 @@ M: object xyz ;
     [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
 ] unit-test
 
-[ t ] [
-    [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
-    [ 5000 [ [ ] times ] each ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
-    [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
-    \ 1+ inlined?
-] unit-test
-
 GENERIC: annotate-entry-test-1 ( x -- )
 
 M: fixnum annotate-entry-test-1 drop ;
@@ -193,7 +176,7 @@ M: fixnum annotate-entry-test-1 drop ;
     2dup >= [
         2drop
     ] [
-        [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
+        [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
     ] if ; inline recursive
 
 : annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
@@ -305,10 +288,6 @@ cell-bits 32 = [
     ] \ + inlined?
 ] unit-test
 
-[ t ] [
-    [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
-] unit-test
-
 : rec ( a -- b )
     dup 0 > [ 1 - rec ] when ; inline recursive
 
@@ -467,7 +446,7 @@ cell-bits 32 = [
 : buffalo-wings ( i seq -- )
     2dup < [
         2dup chicken-fingers
-        [ 1+ ] dip buffalo-wings
+        [ 1 + ] dip buffalo-wings
     ] [
         2drop
     ] if ; inline recursive
@@ -486,7 +465,7 @@ cell-bits 32 = [
 : ribs ( i seq -- )
     2dup < [
         steak
-        [ 1+ ] dip ribs
+        [ 1 + ] dip ribs
     ] [
         2drop
     ] if ; inline recursive
@@ -543,4 +522,4 @@ cell-bits 32 = [
         [ 12 swap nth ] keep
         14 ndrop
     ] cleaned-up-tree nodes>quot
-] unit-test
+] unit-test

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

@@ -1,5 +1,5 @@
-IN: compiler.tree.combinators.tests
 USING: compiler.tree.combinators tools.test kernel ;
+IN: compiler.tree.combinators.tests
 
 { 1 0 } [ [ drop ] each-node ] must-infer-as
 { 1 1 } [ [ ] map-nodes ] must-infer-as