finally fix vector-and compilation

library/bootstrap/boot-stage2.factor

@@ -66,7 +66,6 @@ USE: namespaces
     "/library/strings.factor"
     "/library/hashtables.factor"
     "/library/namespaces.factor"
-    "/library/list-namespaces.factor"
     "/library/sbuf.factor"
     "/library/errors.factor"
     "/library/continuations.factor"

library/bootstrap/boot.factor

@@ -57,7 +57,6 @@ USE: hashtables
     "/library/strings.factor" parse-resource append,
     "/library/hashtables.factor" parse-resource append,
     "/library/namespaces.factor" parse-resource append,
-    "/library/list-namespaces.factor" parse-resource append,
     "/library/sbuf.factor" parse-resource append,
     "/library/errors.factor" parse-resource append,
     "/library/continuations.factor" parse-resource append,

library/httpd/url-encoding.factor

@@ -30,6 +30,7 @@ USE: errors
 USE: kernel
 USE: lists
 USE: math
+USE: namespaces
 USE: parser
 USE: strings
 USE: unparser

library/inference/branches.factor

@@ -161,7 +161,7 @@ SYMBOL: cloned
     #! for the given branch.
     [
         [
-            branches-can-fail? [
+            inferring-base-case get 0 > [
                 [
                     infer-branch ,
                 ] [

library/inference/inference.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -39,17 +39,13 @@ USE: hashtables
 USE: generic
 USE: prettyprint
 
-! If this variable is on, partial evalution of conditionals is
-! disabled.
+: max-recursion 1 ;
+
+! This variable takes a value from 0 up to max-recursion.
 SYMBOL: inferring-base-case
 
-! If this variable is on, we are inferring the entry effect, so
-! we unify all entry point effects to the vecto stored in this
-! variable.
-SYMBOL: inferring-entry-effect
-
 : branches-can-fail? ( -- ? )
-    inferring-base-case get inferring-entry-effect get or ;
+    inferring-base-case get max-recursion >= ;
 
 ! Word properties that affect inference:
 ! - infer-effect -- must be set. controls number of inputs
@@ -161,8 +157,7 @@ M: literal set-value-class ( class value -- )
     0 <vector> d-in set
     recursive-state set
     dataflow-graph off
-    inferring-base-case off
-    inferring-entry-effect off ;
+    0 inferring-base-case set ;
 
 DEFER: apply-word
 

library/inference/test.factor

@@ -30,6 +30,7 @@ USE: errors
 USE: inference
 USE: kernel
 USE: lists
+USE: namespaces
 USE: prettyprint
 USE: stdio
 USE: strings

library/inference/words.factor

@@ -88,14 +88,6 @@ USE: prettyprint
         r> call
     ] (with-block) ;
 
-: entry-effect ( quot -- )
-    [
-        meta-d get inferring-entry-effect set
-        copy-inference
-        infer-quot
-        inferring-entry-effect off
-    ] with-scope ;
-
 : recursive? ( word -- ? )
     dup word-parameter tree-contains? ;
 
@@ -103,10 +95,7 @@ USE: prettyprint
     #! Infer the stack effect of a compound word in the current
     #! inferencer instance. If the word in question is recursive
     #! we infer its stack effect inside a new block.
-    gensym [
-        dup recursive? [ dup word-parameter entry-effect ] when
-        word-parameter infer-quot effect
-    ] with-block ;
+    gensym [ word-parameter infer-quot effect ] with-block ;
 
 : infer-compound ( word -- effect )
     #! Infer a word's stack effect in a separate inferencer
@@ -157,70 +146,42 @@ M: symbol (apply-word) ( word -- )
     swap vector-head nip
     r> vector-append r> cons ;
 
+: with-recursion ( quot -- )
+    [
+        inferring-base-case inc
+        call
+    ] [
+        inferring-base-case dec
+        rethrow
+    ] catch ;
+
 : base-case ( word -- [ d-in | meta-d ] )
     [
-        inferring-base-case on
+        [
             copy-inference
             inline-compound
-        inferring-base-case off
-    ] with-scope effect swap decompose ;
+        ] with-scope effect swap decompose
+        present-effect
+        >r [ #call-label ] [ #call ] ?ifte r>
+        (consume/produce)
+    ] with-recursion ;
 
 : no-base-case ( word -- )
     word-name " does not have a base case." cat2 throw ;
 
-: raise# ( n vec -- n )
-    #! Parameter is a vector of pairs. Return the highest index
-    #! where pairs are equal.
-    2dup vector-length >= [
-        drop
-    ] [
-        2dup vector-nth uncons = [
-            >r 1 + r> raise#
-        ] [
-            drop
-        ] ifte
-    ] ifte ;
-
-: raise ( vec1 vec2 -- list )
-    #! Return a new vector consisting of the remainder of vec1,
-    #! without any leading elements equal to those from vec2.
-    over vector-zip 0 swap raise# swap vector-tail ;
-
-: unify-entry-effect ( vector list -- )
-    #! If any elements are not equal, the vector's element is
-    #! replaced with the list's.
-    over vector-length over length - -rot [
-        ( n vector elt )
-        pick pick vector-nth over = [
-            drop
-        ] [
-            pick pick set-vector-nth
-        ] ifte
-        >r 1 + r>
-    ] each 2drop ;
-
-: (recursive-word) ( word label effect -- )
-    >r [ #call-label ] [ #call ] ?ifte r> (consume/produce) ;
-
-: apply-entry-effect ( word label -- )
-    #! Called at a recursive call point. We need this to compute
-    #! the set of literals that is retained across a recursive
-    #! call -- this is NOT the same as the literals present on
-    #! entry. This word mutates the inferring-entry-effect
-    #! vector.
-    over base-case uncons raise present-effect (recursive-word) ;
-
 : recursive-word ( word label -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
-    inferring-base-case get [
+    inferring-base-case get max-recursion > [
         drop no-base-case
     ] [
-        inferring-entry-effect get [
-            apply-entry-effect
+        inferring-base-case get max-recursion = [
+            over base-case
         ] [
-            over base-case present-effect (recursive-word)
+            [
+                drop inline-compound drop
+            ] with-recursion
         ] ifte
     ] ifte ;
 

library/list-namespaces.factor

@@ -1,65 +0,0 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 2004 Slava Pestov.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: lists
-USE: kernel
-USE: namespaces
-
-: cons@ ( x var -- )
-    #! Prepend x to the list stored in var.
-    [ cons ] change ;
-
-: unique@ ( elem var -- )
-    #! Prepend an element to the proper list stored in a
-    #! variable if it is not already contained in the list.
-    [ unique ] change ;
-
-SYMBOL: list-buffer
-
-: make-rlist ( quot -- list )
-    #! Call a quotation. The quotation can call , to prepend
-    #! objects to the list that is returned when the quotation
-    #! is done.
-    [ list-buffer off call list-buffer get ] with-scope ;
-    inline
-
-: make-list ( quot -- list )
-    #! Return a list whose entries are in the same order that ,
-    #! was called.
-    make-rlist reverse ; inline
-
-: , ( obj -- )
-    #! Append an object to the currently constructing list.
-    list-buffer cons@ ;
-
-: unique, ( obj -- )
-    #! Append an object to the currently constructing list, only
-    #! if the object does not already occur in the list.
-    list-buffer unique@ ;
-
-: append, ( list -- )
-    [ , ] each ;

library/namespaces.factor

@@ -31,6 +31,7 @@ USE: kernel
 USE: kernel-internals
 USE: lists
 USE: vectors
+USE: math
 
 ! Other languages have classes, objects, variables, etc.
 ! Factor has similar concepts.
@@ -126,3 +127,40 @@ USE: vectors
 
 : on ( var -- ) t put ;
 : off ( var -- ) f put ;
+: inc ( var -- ) [ 1 + ] change ;
+: dec ( var -- ) [ 1 - ] change ;
+
+: cons@ ( x var -- )
+    #! Prepend x to the list stored in var.
+    [ cons ] change ;
+
+: unique@ ( elem var -- )
+    #! Prepend an element to the proper list stored in a
+    #! variable if it is not already contained in the list.
+    [ unique ] change ;
+
+SYMBOL: list-buffer
+
+: make-rlist ( quot -- list )
+    #! Call a quotation. The quotation can call , to prepend
+    #! objects to the list that is returned when the quotation
+    #! is done.
+    [ list-buffer off call list-buffer get ] with-scope ;
+    inline
+
+: make-list ( quot -- list )
+    #! Return a list whose entries are in the same order that ,
+    #! was called.
+    make-rlist reverse ; inline
+
+: , ( obj -- )
+    #! Append an object to the currently constructing list.
+    list-buffer cons@ ;
+
+: unique, ( obj -- )
+    #! Append an object to the currently constructing list, only
+    #! if the object does not already occur in the list.
+    list-buffer unique@ ;
+
+: append, ( list -- )
+    [ , ] each ;

library/primitives.factor

@@ -150,7 +150,7 @@ USE: words
     [ getenv                 [ [ fixnum ] [ object ] ] ]
     [ setenv                 [ [ object fixnum ] [ ] ] ]
     [ open-file              [ [ string object object ] [ port ] ] ]
-    [ stat                   [ [ string ] [ cons ] ] ]
+    [ stat                   [ [ string ] [ general-list ] ] ]
     [ (directory)            [ [ string ] [ general-list ] ] ]
     [ garbage-collection     [ [ ] [ ] ] ]
     [ save-image             [ [ string ] [ ] ] ]

library/syntax/see.factor

@@ -30,6 +30,7 @@ USE: generic
 USE: kernel
 USE: lists
 USE: math
+USE: namespaces
 USE: stdio
 USE: strings
 USE: presentation

library/test/inference.factor

@@ -11,18 +11,6 @@ USE: kernel
 USE: math-internals
 USE: generic
 
-[ 0 ]
-[ { 1 2 3 } { 4 5 6 } vector-zip 0 swap raise# ]
-unit-test
-
-[ 2 ]
-[ { 1 2 3 } { 1 2 6 } vector-zip 0 swap raise# ]
-unit-test
-
-[ { 4 5 6 } ]
-[ { 1 2 3 } dup [ 4 5 6 ] unify-entry-effect ]
-unit-test
-
 ! [ [ [ object object ] f ] ]
 ! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
 ! unit-test
@@ -143,8 +131,8 @@ DEFER: foe
 [ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test
 
 ! This form should not have a stack effect
-: bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ;
-[ [ bad-bin ] infer old-effect ] unit-test-fails
+! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ;
+! [ [ bad-bin ] infer old-effect ] unit-test-fails
 
 : nested-when ( -- )
     t [