sequence cleanups

TODO.FACTOR.txt

@@ -6,7 +6,6 @@
 - add a socket timeout
 - unix ffi i/o
 - powerpc has weird callstack residue
-- make-vector and make-string should not need a reverse step
 - console with presentations
 
 + plugin:
@@ -35,7 +34,8 @@
 - out parameters
 - bitfields in C structs
 - SDL_Rect** type
-- struct membres that are not *
+- setting struct members that are not *
+- char[14], etc members -- generalize char255
 - FFI float types
 
 + compiler:
@@ -57,22 +57,22 @@
 
 + sequences
 
+- generic ensure-capacity
 - dipping seq-2nmap, seq-2each
 - remove seq- prefixes
-- seq-append --> nappend
 - generic each some? all? member? memq? all=? top
   index? subseq?
 - index and index* are very slow with lists
 - list map, subset, project, append: not tail recursive
-- : , sequence get push ; : % sequence get nappend ;
 - phase out sbuf-append
 - decide what to do with index-of
 - GENERIC: map
   - list impl same as now
   - sequence impl: clone sequence and call nmap
   - string impl: string>sbuf nmap sbuf>string
-- GENERIC: append
+- GENERIC: append, append3, append*
 - list>vector --> >vector
+- move >list to lists
 
 + kernel:
 

library/alien/aliens.factor

@@ -49,7 +49,7 @@ M: alien = ( obj obj -- ? )
         <namespace> [
           "abi" set
           "name" set
-        ] extend put
+        ] extend swap set
     ] bind ;
 
 : library-abi ( library -- abi )

library/alien/structs.factor

@@ -54,7 +54,10 @@ math namespaces parser strings words ;
     dup struct-constructor
     dup array-constructor
     dup define-nth
-    [ "width" set ] "struct-name" get define-c-type
+    [
+        "width" set
+        [ swap <displaced-alien> ] "getter" set
+    ] "struct-name" get define-c-type
     "void*" c-type "struct-name" get "*" cat2
     c-types get set-hash ;
 

library/bootstrap/boot-stage1.factor

@@ -8,7 +8,7 @@ hashtables ;
 
 "/library/bootstrap/primitives.factor" run-resource
 
-: pull-in ( list -- ) [ dup print parse-resource append, ] each ;
+: pull-in ( list -- ) [ dup print parse-resource % ] each ;
 
 ! The make-list form creates a boot quotation
 [
@@ -16,26 +16,26 @@ hashtables ;
         "/version.factor"
         "/library/stack.factor"
         "/library/combinators.factor"
-        "/library/sequences.factor"
+        "/library/collections/sequences.factor"
-        "/library/arrays.factor"
+        "/library/collections/arrays.factor"
         "/library/kernel.factor"
-        "/library/cons.factor"
+        "/library/collections/cons.factor"
-        "/library/assoc.factor"
+        "/library/collections/assoc.factor"
         "/library/math/math.factor"
         "/library/math/integer.factor"
         "/library/math/ratio.factor"
         "/library/math/float.factor"
         "/library/math/complex.factor"
-        "/library/lists.factor"
+        "/library/collections/lists.factor"
-        "/library/vectors.factor"
+        "/library/collections/vectors.factor"
-        "/library/strings.factor"
+        "/library/collections/strings.factor"
-        "/library/sequences-epilogue.factor"
+        "/library/collections/sequences-epilogue.factor"
-        "/library/vectors-epilogue.factor"
+        "/library/collections/vectors-epilogue.factor"
-        "/library/hashtables.factor"
+        "/library/collections/hashtables.factor"
-        "/library/namespaces.factor"
+        "/library/collections/namespaces.factor"
         "/library/words.factor"
         "/library/vocabularies.factor"
-        "/library/sbuf.factor"
+        "/library/collections/sbuf.factor"
         "/library/errors.factor"
         "/library/continuations.factor"
         "/library/threads.factor"

library/bootstrap/init.factor

@@ -1,41 +1,11 @@
-! :folding=indent:collapseFolds=1:
+! Copyright (C) 2004, 2005 Slava Pestov.
-
+! See http://factor.sf.net/license.txt for BSD license.
-! $Id$
-!
-! Copyright (C) 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: kernel
-USE: namespaces
+USING: namespaces parser stdio streams threads words ;
-USE: parser
-USE: stdio
-USE: streams
-USE: threads
-USE: words
 
 : boot ( -- )
     #! Initialize an interpreter with the basic services.
-    init-namespaces
+    global >n
     init-threads
     init-stdio
     "HOME" os-env [ "." ] unless* "~" set

library/cli.factor

@@ -22,7 +22,7 @@ kernel-internals ;
 
 : cli-var-param ( name value -- ) swap ":" split set-path ;
 
-: cli-bool-param ( name -- ) "no-" ?string-head not put ;
+: cli-bool-param ( name -- ) "no-" ?string-head not swap set ;
 
 : cli-param ( param -- )
     #! Handle a command-line argument starting with '-' by

library/collections/namespaces.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: namespaces
-USING: hashtables kernel kernel-internals lists math
+USING: hashtables kernel kernel-internals lists math sequences
 strings vectors ;
 
 ! Other languages have classes, objects, variables, etc.
@@ -26,6 +26,7 @@ strings vectors ;
 ! namespace pushed on the namespace stack.
 
 : namestack ( -- ns ) 3 getenv ; inline
+
 : set-namestack ( ns -- ) 3 setenv ; inline
 
 : namespace ( -- namespace )
@@ -33,18 +34,14 @@ strings vectors ;
     namestack car ;
 
 : >n ( namespace -- n:namespace )
-    #! Push a namespace on the namespace stack.
+    #! Push a namespace on the name stack.
     namestack cons set-namestack ; inline
 
 : n> ( n:namespace -- namespace )
-    #! Pop the top of the namespace stack.
+    #! Pop the top of the name stack.
     namestack uncons set-namestack ; inline
 
 : global ( -- g ) 4 getenv ;
-: set-global ( g -- ) 4 setenv ;
-
-: init-namespaces ( -- )
-    global >n ;
 
 : <namespace> ( -- n )
     #! Create a new namespace.
@@ -68,7 +65,10 @@ strings vectors ;
     namestack (get) ;
 
 : set ( value variable -- ) namespace set-hash ;
-: put ( variable value -- ) swap set ;
+
+: on ( var -- ) t swap set ;
+
+: off ( var -- ) f swap set ;
 
 : nest ( variable -- hash )
     #! If the variable is set in the current namespace, return
@@ -90,7 +90,7 @@ strings vectors ;
     #! namestack.
     <namespace> >n call n> drop ; inline
 
-: extend ( object code -- object )
+: extend ( namespace code -- namespace )
     #! Used in code like this:
     #! : <subclass>
     #!      <superclass> [
@@ -98,67 +98,46 @@ strings vectors ;
     #!      ] extend ;
     over >r bind r> ; inline
 
-: on ( var -- ) t put ;
+! Building sequences
-: off ( var -- ) f put ;
+SYMBOL: sequence
-: inc ( var -- ) [ 1 + ] change ;
-: dec ( var -- ) [ 1 - ] change ;
 
-: cons@ ( x var -- )
+: make-seq ( quot sequence -- sequence )
-    #! Prepend x to the list stored in var.
+    #! Call , and % from the quotation to append to a sequence.
-    [ cons ] change ;
+    [ sequence set call sequence get ] with-scope ; inline
-
-: 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
-
-: make-string ( quot -- string )
-    #! Call a quotation. The quotation can call , to prepend
-    #! objects to the list that is returned when the quotation
-    #! is done.
-    make-list cat ; inline
-
-: make-rstring ( quot -- string )
-    #! Return a string whose entries are in the same order that ,
-    #! was called.
-    make-rlist cat ; inline
-
-: make-vector ( quot -- list )
-    #! Return a vector whose entries are in the same order that
-    #! , was called.
-    make-list list>vector ; inline
 
 : , ( obj -- )
-    #! Append an object to the currently constructing list.
+    #! Add to the sequence being built with make-seq.
-    list-buffer cons@ ;
+    sequence get dup sbuf? [ sbuf-append ] [ push ] ifte ;
-
-: 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 ;
 
 : literal, ( word -- )
     #! Append some code that pushes the word on the stack. Used
     #! when building quotations.
     unit , \ car , ;
 
+: unique, ( obj -- )
+    #! Add the object to the sequence being built with make-seq
+    #! unless an equal object has already been added.
+    sequence get 2dup index -1 = [ push ] [ 2drop ] ifte ;
+
+: % ( seq -- )
+    #! Append to the sequence being built with make-seq.
+    sequence get swap nappend ;
+
+: make-vector ( quot -- vector )
+    100 <vector> make-seq ; inline
+
+: make-list ( quot -- list )
+    make-vector >list ; inline
+
+: make-sbuf ( quot -- sbuf )
+    100 <sbuf> make-seq ; inline
+
+: make-string ( quot -- string )
+    make-sbuf sbuf>string ; inline
+
+: make-rstring ( quot -- string )
+    make-sbuf dup nreverse sbuf>string ; inline
+
 ! Building hashtables, and computing a transitive closure.
 SYMBOL: hash-buffer
 

library/collections/sequences-epilogue.factor

@@ -96,10 +96,17 @@ M: sequence (tree-each) [ swap call ] seq-each-with ;
 
 : >pop> ( stack -- stack ) dup pop drop ;
 
+: (exchange) ( seq i j -- seq[i] j seq )
+    pick >r >r swap nth r> r> ;
+
+: exchange ( seq i j -- )
+    #! Exchange seq[i] and seq[j].
+    3dup >r >r >r (exchange) r> r> r>
+    swap (exchange) set-nth set-nth ;
+
 : (nreverse) ( seq i -- )
     #! Swap seq[i] with seq[length-i-1].
-    
+    over length over - 1 - exchange ;
-    ;
 
 : nreverse ( seq -- )
     #! Destructively reverse seq.

library/compiler/xt.factor

@@ -87,7 +87,9 @@ C: relative ( word -- )
     [ just-compiled swap set-relative-where ] keep
     [ compiled-offset swap set-relative-to ] keep ;
 
-: relative ( word -- ) <relative> deferred-xts cons@ ;
+: deferred-xt deferred-xts [ cons ] change ;
+
+: relative ( word -- ) <relative> deferred-xt ;
 
 : relative-fixup ( relative -- addr )
     dup relative-word compiled-xt swap relative-to - ;
@@ -102,7 +104,7 @@ C: absolute ( word -- )
     [ just-compiled swap set-absolute-where ] keep ;
 
 : absolute ( word -- )
-    dup f rel-word <absolute> deferred-xts cons@ ;
+    dup f rel-word <absolute> deferred-xt ;
 
 : >absolute dup absolute-word compiled-xt swap absolute-where ;
 
@@ -120,11 +122,11 @@ C: relative-bitfld ( word mask -- )
 
 : relative-24 ( word -- )
     BIN: 11111111111111111111111100 <relative-bitfld>
-    deferred-xts cons@ ;
+    deferred-xt ;
 
 : relative-14 ( word -- )
     BIN: 1111111111111100 <relative-bitfld>
-    deferred-xts cons@ ;
+    deferred-xt ;
 
 : or-compiled ( n off -- )
     [ compiled-cell bitor ] keep set-compiled-cell ;
@@ -146,8 +148,7 @@ C: absolute-16/16 ( word -- )
 
 M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
 
-: absolute-16/16 ( word -- )
+: absolute-16/16 ( word -- ) <absolute-16/16> deferred-xt ;
-    <absolute-16/16> deferred-xts cons@ ;
 
 : compiling? ( word -- ? )
     #! A word that is compiling or already compiled will not be
@@ -169,4 +170,8 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ;
     [ call  fixup-xts  commit-xts ] with-scope ;
 
 : postpone-word ( word -- )
-    dup compiling? [ drop ] [ compile-words unique@ ] ifte ;
+    dup compiling? [
+        drop
+    ] [
+        compile-words [ unique ] change
+    ] ifte ;

library/generic/predicate.factor

@@ -9,7 +9,7 @@ SYMBOL: predicate
 
 : predicate-dispatch ( existing definition class -- dispatch )
     [
-        \ dup , "predicate" word-prop append, , , \ ifte ,
+        \ dup , "predicate" word-prop % , , \ ifte ,
     ] make-list ;
 
 : predicate-method ( vtable definition class type# -- )
@@ -44,7 +44,7 @@ predicate [
 : define-predicate ( class predicate definition -- )
     pick over "definition" set-word-prop
     pick "superclass" word-prop "predicate" word-prop
-    [ \ dup , append, , [ drop f ] , \ ifte , ] make-list
+    [ \ dup , % , [ drop f ] , \ ifte , ] make-list
     define-compound
     predicate "metaclass" set-word-prop ;
 

library/generic/union.factor

@@ -26,7 +26,7 @@ union [ 2drop t ] "class<" set-word-prop
     [
         [
             \ dup ,
-            unswons "predicate" word-prop append,
+            unswons "predicate" word-prop %
             [ drop t ] ,
             union-predicate ,
             \ ifte ,

library/httpd/browser-responder.factor

@@ -78,7 +78,7 @@ errors unparser logging listener url-encoding hashtables memory ;
 : write-word-source ( vocab word -- )
   #! Write the source for the given word from the vocab as HTML.
   <namespace> [
-    "allow-edit?" get [ "Edit" [ "edit-state" t put ] quot-href <br/> ] when
+    "allow-edit?" get [ "Edit" [ "edit-state" on ] quot-href <br/> ] when
     "edit-state" get [
       write-editable-word-source 
     ] [ 
@@ -131,10 +131,10 @@ errors unparser logging listener url-encoding hashtables memory ;
   #! Return a list of vocabularies that all words in a vocabulary
   #! uses.
   <namespace> [
-    "result" f put
+    "result" off
     words [
       word-uses [
-        "result" unique@
+        "result" [ unique ] change
       ] each
     ] each 
     "result" get
@@ -202,7 +202,7 @@ errors unparser logging listener url-encoding hashtables memory ;
       ] show [
         "allow-edit?" get [ 
           "eval" get [ 
-             "eval" f put
+             "eval" off
              "Editing has been disabled." show-message-page 
           ] when
         ] unless

library/httpd/html-tags.factor

@@ -91,7 +91,7 @@ USE: words
     #! and sets it's value to the current value on the stack.
     #! If there is no previous attribute, no value is expected
     #! on the stack.
-    "current-attribute" get [ swons "attrs" cons@ ] when* ;
+    "current-attribute" get [ swons "attrs" [ cons ] change ] when* ;
 
 ! HTML tag words
 ! 

library/inference/branches.factor

@@ -156,7 +156,7 @@ SYMBOL: cloned
     over [
         >r
         dupd cons
-        recursive-state cons@
+        recursive-state [ cons ] change
         r> call
     ] (with-block) ;
 

library/inference/dataflow.factor

@@ -99,7 +99,7 @@ SYMBOL: node-param
 
 : dataflow, ( param op -- node )
     #! Add a node to the dataflow IR.
-    <dataflow-node> dup dataflow-graph cons@ ;
+    <dataflow-node> dup dataflow-graph [ cons ] change ;
 
 : dataflow-drop, ( -- )
     #! Remove the top stack element and add a dataflow node

library/inference/words.factor

@@ -119,10 +119,10 @@ M: compound apply-word ( word -- )
 
 : with-recursion ( quot -- )
     [
-        inferring-base-case inc
+        inferring-base-case [ 1 + ] change
         call
     ] [
-        inferring-base-case dec
+        inferring-base-case [ 1 - ] change
         rethrow
     ] catch ;
 

library/math/matrices.factor

@@ -145,7 +145,7 @@ M: matrix v. ( m1 m2 -- m )
 
 : ]M
     reverse [ dup car length swap length ] keep
-    [ [ append, ] each ] make-vector <matrix> swons ; parsing
+    [ [ % ] each ] make-vector <matrix> swons ; parsing
 
 : row-list ( matrix -- list )
     #! A list of lists, where each sublist is a row of the

library/syntax/parse-syntax.factor

@@ -95,17 +95,17 @@ BUILTIN: f 9 ;  : f f swons ; parsing
 
 : USE:
     #! Add vocabulary to search path.
-    scan "use" cons@ ; parsing
+    scan use+ ; parsing
 
 : USING:
     #! A list of vocabularies terminated with ;
     string-mode on
-    [ string-mode off [ "use" cons@ ] each ]
+    [ string-mode off [ use+ ] each ]
     f ; parsing
 
 : IN:
     #! Set vocabulary for new definitions.
-    scan dup "use" cons@ "in" set ; parsing
+    scan dup use+ "in" set ; parsing
 
 ! Char literal
 : CHAR: ( -- ) 0 scan next-char drop swons ; parsing

library/syntax/see.factor

@@ -8,7 +8,7 @@ presentation stdio streams strings unparser words ;
 : vocab-actions ( search -- list )
     [
         [[ "Words"   "words ."       ]]
-        [[ "Use"     "\"use\" cons@" ]]
+        [[ "Use"     "use+" ]]
         [[ "In"      "\"in\" set"    ]]
     ] ;
 

library/test/lists/namespaces.factor

@@ -3,6 +3,9 @@ USE: lists
 USE: namespaces
 USE: test
 
+: cons@ [ cons ] change ;
+: unique@ [ unique ] change ;
+
 [ [ 1 ] ] [ 1 f "x" set "x" cons@ "x" get ] unit-test
 [ [[ 1 2 ]] ] [ 1 2 "x" set "x" cons@ "x" get ] unit-test
 [ [ 1 2 ] ] [ 1 [ 2 ] "x" set "x" cons@ "x" get ] unit-test

library/test/test.factor

@@ -41,14 +41,10 @@ prettyprint sequences stdio strings unparser vectors words ;
 
 SYMBOL: failures
 
+: failure failures [ cons ] change ;
+
 : test-handler ( name quot -- ? )
-    [
+    [ [ dup error. cons failure f ] [ t ] ifte* ] catch ;
-        [
-            dup error. cons failures cons@ f
-        ] [
-            t
-        ] ifte*
-    ] catch ;
 
 : test-path ( name -- path )
     "/library/test/" swap ".factor" cat3 ;
@@ -80,7 +76,7 @@ SYMBOL: failures
             "inference" "dataflow" "interpreter" "alien"
             "line-editor" "gadgets" "memory" "redefine"
             "annotate"
-        ] append,
+        ] %
         
         os "win32" = [
             "buffer" ,
@@ -93,7 +89,7 @@ SYMBOL: failures
                 "compiler/stack" "compiler/ifte"
                 "compiler/generic" "compiler/bail-out"
                 "compiler/linearizer"
-            ] append,
+            ] %
         ] unless
         
         [
@@ -102,7 +98,7 @@ SYMBOL: failures
             "benchmark/continuations" "benchmark/ack"
             "benchmark/hashtables" "benchmark/strings"
             "benchmark/vectors"
-        ] append,
+        ] %
     ] make-list ;
 
 : passed.

library/test/vectors.factor

@@ -1,6 +1,6 @@
 IN: temporary
-USING: kernel kernel-internals math namespaces random sequences
+USING: kernel kernel-internals lists math namespaces random
-strings test vectors ;
+sequences strings test vectors ;
 
 [ 3 ] [ [ t f t ] length ] unit-test
 [ 3 ] [ { t f t } length ] unit-test
@@ -91,3 +91,9 @@ unit-test
 
 [ -1 ] [ 5 { } index ] unit-test
 [ 4 ] [ 5 { 1 2 3 4 5 } index ] unit-test
+
+[ { "c" "b" "a" } ] [ { "a" "b" "c" } clone dup 0 2 exchange ] unit-test
+
+[ t ] [
+    100 count dup list>vector dup nreverse >list >r reverse r> =
+] unit-test

library/vocabularies.factor

@@ -21,7 +21,7 @@ SYMBOL: vocabularies
     vocab dup [ hash-values [ ] subset word-sort ] when ;
 
 : all-words ( -- list )
-    [ vocabs [ words append, ] each ] make-list ;
+    [ vocabs [ words % ] each ] make-list ;
 
 : each-word ( quot -- )
     #! Apply a quotation to each word in the image.