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

basis/compiler/tests/optimizer.factor

@@ -362,3 +362,18 @@ TUPLE: some-tuple x ;
 [ 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
+
+! Loop detection problem found by doublec
+SYMBOL: counter
+
+DEFER: loop-bbb
+
+: loop-aaa ( -- )
+    counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
+
+: loop-bbb ( -- )
+    [ loop-aaa ] with-scope ; inline recursive
+
+: loop-ccc ( -- ) loop-bbb ;
+
+[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test

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

@@ -148,3 +148,27 @@ DEFER: a'
     [ a' ] build-tree analyze-recursive
     \ b' label-is-loop?
 ] unit-test
+
+DEFER: a''
+
+: b'' ( -- )
+    a'' ; inline recursive
+
+: a'' ( -- )
+    b'' a'' ; inline recursive
+
+[ t ] [
+    [ a'' ] build-tree analyze-recursive
+    \ a'' label-is-not-loop?
+] unit-test
+
+: loop-in-non-loop ( x quot: ( i -- ) -- )
+    over 0 > [
+        [ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
+    ] [ 2drop ] if ; inline recursive
+
+[ t ] [
+    [ 10 [ [ drop ] each-integer ] loop-in-non-loop ]
+    build-tree analyze-recursive
+    \ (each-integer) label-is-loop?
+] unit-test

basis/compiler/tree/recursive/recursive.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces accessors sequences deques
+USING: kernel assocs arrays namespaces accessors sequences deques
 search-deques compiler.tree compiler.tree.combinators ;
 IN: compiler.tree.recursive
 
@@ -50,11 +50,10 @@ GENERIC: collect-loop-info* ( tail? node -- )
     loop-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
-    nip
     [
         [
             label>>
-            [ loop-stack [ swap suffix ] change ]
+            [ swap 2array loop-stack [ swap suffix ] change ]
             [ remember-loop-info ]
             [ t >>loop? drop ]
             tri
@@ -62,7 +61,7 @@ M: #recursive collect-loop-info*
         [ t swap child>> (collect-loop-info) ] bi
     ] with-scope ;
 
-: current-loop-nesting ( label -- labels )
+: current-loop-nesting ( label -- alist )
     loop-stack get swap loop-heights get at tail ;
 
 : disqualify-loop ( label -- )
@@ -71,7 +70,10 @@ M: #recursive collect-loop-info*
 M: #call-recursive collect-loop-info*
     label>>
     swap [ dup disqualify-loop ] unless
-    dup current-loop-nesting [ loop-calls get push-at ] with each ;
+    dup current-loop-nesting
+    [ keys [ loop-calls get push-at ] with each ]
+    [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
+    bi ;
 
 M: #if collect-loop-info*
     children>> [ (collect-loop-info) ] with each ;

basis/http/client/client.factor

@@ -120,7 +120,7 @@ SYMBOL: redirects
     ] if ; inline recursive
 
 : read-unchunked ( quot: ( chunk -- ) -- )
-    8192 read dup [
+    8192 read-partial dup [
         [ swap call ] [ drop read-unchunked ] 2bi
     ] [ 2drop ] if ; inline recursive
 

basis/tools/deploy/shaker/shaker.factor

@@ -373,7 +373,8 @@ SYMBOL: deploy-vocab
     r> strip-words
     compress-byte-arrays
     compress-quotations
-    compress-strings ;
+    compress-strings
+    H{ } clone classes:next-method-quot-cache set-global ;
 
 : (deploy) ( final-image vocab config -- )
     #! Does the actual work of a deployment in the slave