diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 444780df70..eb605a9ec8 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 71cafa7b49..380948ced2 100644 --- a/library/bootstrap/boot.factor +++ b/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, diff --git a/library/httpd/url-encoding.factor b/library/httpd/url-encoding.factor index 0993a14cfa..bada6ff4fa 100644 --- a/library/httpd/url-encoding.factor +++ b/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 diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 60e107047a..a01924c3dd 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -161,7 +161,7 @@ SYMBOL: cloned #! for the given branch. [ [ - branches-can-fail? [ + inferring-base-case get 0 > [ [ infer-branch , ] [ diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 02dd8fda87..1df0f2199b 100644 --- a/library/inference/inference.factor +++ b/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 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 diff --git a/library/inference/test.factor b/library/inference/test.factor index 9cbd8166d3..6f325eb54f 100644 --- a/library/inference/test.factor +++ b/library/inference/test.factor @@ -30,6 +30,7 @@ USE: errors USE: inference USE: kernel USE: lists +USE: namespaces USE: prettyprint USE: stdio USE: strings diff --git a/library/inference/words.factor b/library/inference/words.factor index d68ee4fee6..9d77cd54b2 100644 --- a/library/inference/words.factor +++ b/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 ; + [ + copy-inference + inline-compound + ] 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 ; diff --git a/library/list-namespaces.factor b/library/list-namespaces.factor deleted file mode 100644 index 0bab6cbfaa..0000000000 --- a/library/list-namespaces.factor +++ /dev/null @@ -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 ; diff --git a/library/namespaces.factor b/library/namespaces.factor index d5ab7f413c..e1632b9c47 100644 --- a/library/namespaces.factor +++ b/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 ; diff --git a/library/primitives.factor b/library/primitives.factor index 92b827dd0b..9847467c24 100644 --- a/library/primitives.factor +++ b/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 ] [ ] ] ] diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 32f288980c..b8d20c1ccb 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -30,6 +30,7 @@ USE: generic USE: kernel USE: lists USE: math +USE: namespaces USE: stdio USE: strings USE: presentation diff --git a/library/test/inference.factor b/library/test/inference.factor index b20194370a..31ab36ece6 100644 --- a/library/test/inference.factor +++ b/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 [