basis: use lint.vocabs tool to trim using lists

[factor.git] / basis / lists / lists.factor

diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor
index 0eedb808891605748f2857c2d0c1d4bb9d4dcad0..be50f8eeedff8e07dbee6b7fa64cb371a739753c 100644 (file)
--- a/basis/lists/lists.factor
+++ b/basis/lists/lists.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors math arrays vectors classes words
-combinators.short-circuit combinators locals ;
+USING: accessors combinators combinators.short-circuit kernel
+lexer make math namespaces parser sequences words ;
 IN: lists
 
 ! List Protocol
@@ -9,14 +9,14 @@ MIXIN: list
 GENERIC: car ( cons -- car )
 GENERIC: cdr ( cons -- cdr )
 GENERIC: nil? ( object -- ?   )
-    
-TUPLE: cons { car read-only } { cdr read-only } ;
 
-C: cons cons
+TUPLE: cons-state { car read-only } { cdr read-only } ;
 
-M: cons car ( cons -- car ) car>> ;
+C: cons cons-state
 
-M: cons cdr ( cons -- cdr ) cdr>> ;
+M: cons-state car car>> ;
+
+M: cons-state cdr cdr>> ;
 
 SINGLETON: +nil+
 M: +nil+ nil? drop t ;
@@ -36,15 +36,15 @@ M: object nil? drop f ;
 
 : 1list? ( list -- ? ) { [ nil? not ] [ cdr nil? ] } 1&& ; inline
 
-: 2list ( a b -- cons ) nil cons cons ; inline
+: 2list ( a b -- cons ) 1list cons ; inline
 
-: 3list ( a b c -- cons ) nil cons cons cons ; inline
+: 3list ( a b c -- cons ) 2list cons ; inline
 
 : cadr ( list -- elt ) cdr car ; inline
- 
-: 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; inline
- 
-: 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; inline
+
+: 2car ( list -- car cadr ) uncons car ; inline
+
+: 3car ( list -- car cadr caddr ) uncons uncons car ; inline
 
 : lnth ( n list -- elt ) swap [ cdr ] times car ; inline
 
@@ -53,51 +53,97 @@ M: object nil? drop f ;
 : (leach) ( list quot -- cdr quot )
     [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
 
+: (2leach) ( list1 list2 quot -- cdr1 cdr2 quot )
+    [ [ [ car ] bi@ ] dip call ] [ [ [ cdr ] bi@ ] dip ] 3bi ; inline
+
 PRIVATE>
 
-: leach ( list quot: ( elt -- ) -- )
+: leach ( ... list quot: ( ... elt -- ... ) -- ... )
     over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
 
-: lmap ( list quot: ( elt -- ) -- result )
-    over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
+: 2leach ( ... list1 list2 quot: ( ... elt1 elt2 -- ... ) -- ... )
+    2over [ nil? ] either? [ 3drop ] [ (2leach) 2leach ] if ; inline recursive
 
-: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+: lreduce ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
     swapd leach ; inline
 
-:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
-    list nil? [ identity ] [
+: 2lreduce ( ... list1 list2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
+    -rotd 2leach ; inline
+
+: foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
+    swapd leach ; inline
+
+:: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
+    list nil? [
+        identity
+    ] [
         list cdr identity quot foldr
         list car quot call
     ] if ; inline recursive
 
 : llength ( list -- n )
-    0 [ drop 1+ ] foldl ;
+    0 [ drop 1 + ] foldl ;
 
-: lreverse ( list -- newlist )    
-    nil [ swap cons ] foldl ;
+: lreverse ( list -- newlist )
+    nil [ swons ] foldl ;
 
-: lappend ( list1 list2 -- newlist )    
-    [ lreverse ] dip [ swap cons ] foldl ;
+: lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result )
+    [ nil ] dip [ swapd dip cons ] curry foldl lreverse ; inline
+
+: lappend ( list1 list2 -- newlist )
+    [ lreverse ] dip [ swons ] foldl ;
 
 : lcut ( list index -- before after )
-    [ nil ] dip
-    [ [ unswons ] dip cons ] times
-    lreverse swap ;
+    [ nil ] dip [ [ unswons ] dip cons ] times lreverse swap ;
 
-: sequence>list ( sequence -- list )    
+: sequence>list ( sequence -- list )
     <reversed> nil [ swons ] reduce ;
 
-: lmap>array ( list quot -- array )
-    accumulator [ leach ] dip { } like ; inline
+: lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array )
+    collector [ leach ] dip { } like ; inline
 
-: list>array ( list -- array )  
+: list>array ( list -- array )
     [ ] lmap>array ;
 
-:: traverse ( list pred quot: ( list/elt -- result ) -- result )
-    list [| elt |
-        elt dup pred call [ quot call ] when
-        dup list? [ pred quot traverse ] when
-    ] lmap ; inline recursive
+: deeplist>array ( list -- array )
+    [ dup list? [ deeplist>array ] when ] lmap>array ;
 
-INSTANCE: cons list
+INSTANCE: cons-state list
 INSTANCE: +nil+ list
+
+GENERIC: >list ( object -- list )
+
+M: list >list ;
+
+M: sequence >list sequence>list ;
+
+ERROR: list-syntax-error ;
+
+<PRIVATE
+
+: items>list ( sequence -- list )
+    [ +nil+ ] [
+        <reversed> unclip-slice [ swons ] reduce
+    ] if-empty ;
+
+: ?list-syntax-error ( right-of-dot? -- )
+    building get empty? or [ list-syntax-error ] when ;
+
+: (parse-list-literal) ( right-of-dot? -- )
+    scan-token {
+        { "}" [ drop +nil+ , ] }
+        { "." [ ?list-syntax-error t (parse-list-literal) ] }
+        [
+            parse-datum dup parsing-word? [
+                V{ } clone swap execute-parsing first
+            ] when
+            , [ "}" expect ] [ f (parse-list-literal) ] if
+        ]
+    } case ;
+
+: parse-list-literal ( -- list )
+    [ f (parse-list-literal) ] { } make items>list ;
+
+PRIVATE>
+
+SYNTAX: L{ parse-list-literal suffix! ;