! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit kernel
-lexer locals make math parser sequences words ;
+lexer make math namespaces parser sequences words ;
IN: lists
! List Protocol
C: cons cons-state
-M: cons-state car ( cons -- car ) car>> ;
+M: cons-state car car>> ;
-M: cons-state cdr ( cons -- cdr ) cdr>> ;
+M: cons-state cdr cdr>> ;
SINGLETON: +nil+
M: +nil+ nil? drop t ;
: (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 -- ... ) -- ... )
over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
+: 2leach ( ... list1 list2 quot: ( ... elt1 elt2 -- ... ) -- ... )
+ 2over [ nil? ] either? [ 3drop ] [ (2leach) 2leach ] if ; inline recursive
+
+: lreduce ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
+ swapd leach ; inline
+
+: 2lreduce ( ... list1 list2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
+ -rotd 2leach ; inline
+
: foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd leach ; inline
<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 ] when t (parse-list-literal) ] }
+ { "." [ ?list-syntax-error t (parse-list-literal) ] }
[
parse-datum dup parsing-word? [
V{ } clone swap execute-parsing first