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

basis/compiler/generator/iterator/iterator.factor

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

basis/compiler/tests/intrinsics.factor

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

basis/compiler/tests/optimizer.factor

@@ -358,3 +358,7 @@ TUPLE: some-tuple x ;
 
 [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
 [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
+
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+
+[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test

basis/compiler/tree/cleanup/cleanup.factor

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

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

@@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-1 ( a -- b )
     [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
 
-[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
     [ call-recursive-dce-1 ] optimize-quot squish
 ] unit-test
 
@@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests
     [ f call-recursive-dce-2 drop ] optimize-quot squish
 ] unit-test
 
-[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
     [ f call-recursive-dce-2 ] optimize-quot squish
 ] unit-test
 
@@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-4 ( a -- b )
     call-recursive-dce-4 ; inline recursive
 
-[ [ "WRAP" [ "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" ] label ] ] [
     [ call-recursive-dce-4 ] optimize-quot squish
 ] unit-test
 

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

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

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

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

basis/cpu/x86/64/64.factor

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

basis/cpu/x86/intrinsics/intrinsics.factor

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

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

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

basis/xml-rpc/xml-rpc.factor

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

core/io/binary/binary-tests.factor

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

extra/html/templates/chloe/syntax/syntax.factor

@@ -23,7 +23,7 @@ tags global [ H{ } clone or ] change-at
 
 MEMO: chloe-name ( string -- name )
     name new
-        swap >>tag
+        swap >>main
         chloe-ns >>url ;
 
 : required-attr ( tag name -- value )
@@ -45,7 +45,7 @@ MEMO: chloe-name ( string -- name )
 : attrs>slots ( tag tuple -- )
     [ attrs>> ] [ <mirror> ] bi*
     '[
-        swap tag>> dup "name" =
+        swap main>> dup "name" =
         [ 2drop ] [ , set-at ] if
     ] assoc-each ;
 

extra/inverse/inverse-tests.factor

@@ -62,10 +62,10 @@ C: <nil> nil
 [ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
 
 : empty-cons ( -- cons ) cons new ;
-: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
+: cons* ( cdr car -- cons ) cons boa ;
 
 [ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
-[ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
+[ 1 2 ] [ 1 2 <cons> [ cons* ] undo ] unit-test
 
 [ t ] [ pi [ pi ] matches? ] unit-test
 [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test

extra/io/files/unique/unique-tests.factor

@@ -1,3 +1,5 @@
+USING: io.encodings.ascii sequences strings io io.files accessors
+tools.test kernel io.files.unique ;
 IN: io.files.unique.tests
 
 [ 123 ] [

extra/math/bitfields/lib/lib.factor

@@ -1,14 +1,14 @@
 USING: hints kernel math ;
 IN: math.bitfields.lib
 
-: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
+: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
-: set-bit ( x n -- y ) 2^ bitor ; foldable
+: set-bit ( x n -- y ) 2^ bitor ; inline
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
+: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
-: unmask ( x n -- ? ) bitnot bitand ; foldable
+: unmask ( x n -- ? ) bitnot bitand ; inline
-: unmask? ( x n -- ? ) unmask 0 > ; foldable
+: unmask? ( x n -- ? ) unmask 0 > ; inline
-: mask ( x n -- ? ) bitand ; foldable
+: mask ( x n -- ? ) bitand ; inline
-: mask? ( x n -- ? ) mask 0 > ; foldable
+: mask? ( x n -- ? ) mask 0 > ; inline
-: wrap ( m n -- m' ) 1- bitand ; foldable
+: wrap ( m n -- m' ) 1- bitand ; inline
 : bits ( m n -- m' ) 2^ wrap ; inline
 : mask-bit ( m n -- m' ) 1- 2^ mask ; inline