1 ! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators combinators.short-circuit kernel
4 lexer make math namespaces parser sequences words ;
9 GENERIC: car ( cons -- car )
10 GENERIC: cdr ( cons -- cdr )
11 GENERIC: nil? ( object -- ? )
13 TUPLE: cons-state { car read-only } { cdr read-only } ;
17 M: cons-state car car>> ;
19 M: cons-state cdr cdr>> ;
22 M: +nil+ nil? drop t ;
23 M: object nil? drop f ;
25 : atom? ( obj -- ? ) list? not ; inline
27 : nil ( -- symbol ) +nil+ ; inline
29 : uncons ( cons -- car cdr ) [ car ] [ cdr ] bi ; inline
31 : swons ( cdr car -- cons ) swap cons ; inline
33 : unswons ( cons -- cdr car ) uncons swap ; inline
35 : 1list ( obj -- cons ) nil cons ; inline
37 : 1list? ( list -- ? ) { [ nil? not ] [ cdr nil? ] } 1&& ; inline
39 : 2list ( a b -- cons ) 1list cons ; inline
41 : 3list ( a b c -- cons ) 2list cons ; inline
43 : cadr ( list -- elt ) cdr car ; inline
45 : 2car ( list -- car cadr ) uncons car ; inline
47 : 3car ( list -- car cadr caddr ) uncons uncons car ; inline
49 : lnth ( n list -- elt ) swap [ cdr ] times car ; inline
53 : (leach) ( list quot -- cdr quot )
54 [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
56 : (2leach) ( list1 list2 quot -- cdr1 cdr2 quot )
57 [ [ [ car ] bi@ ] dip call ] [ [ [ cdr ] bi@ ] dip ] 3bi ; inline
61 : leach ( ... list quot: ( ... elt -- ... ) -- ... )
62 over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
64 : 2leach ( ... list1 list2 quot: ( ... elt1 elt2 -- ... ) -- ... )
65 2over [ nil? ] either? [ 3drop ] [ (2leach) 2leach ] if ; inline recursive
67 : lreduce ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
70 : 2lreduce ( ... list1 list2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
73 : foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
76 :: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
80 list cdr identity quot foldr
82 ] if ; inline recursive
84 : llength ( list -- n )
85 0 [ drop 1 + ] foldl ;
87 : lreverse ( list -- newlist )
90 : lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result )
91 [ nil ] dip [ swapd dip cons ] curry foldl lreverse ; inline
93 : lappend ( list1 list2 -- newlist )
94 [ lreverse ] dip [ swons ] foldl ;
96 : lcut ( list index -- before after )
97 [ nil ] dip [ [ unswons ] dip cons ] times lreverse swap ;
99 : sequence>list ( sequence -- list )
100 <reversed> nil [ swons ] reduce ;
102 : lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array )
103 collector [ leach ] dip { } like ; inline
105 : list>array ( list -- array )
108 : deeplist>array ( list -- array )
109 [ dup list? [ deeplist>array ] when ] lmap>array ;
111 INSTANCE: cons-state list
114 GENERIC: >list ( object -- list )
118 M: sequence >list sequence>list ;
120 ERROR: list-syntax-error ;
124 : items>list ( sequence -- list )
126 <reversed> unclip-slice [ swons ] reduce
129 : ?list-syntax-error ( right-of-dot? -- )
130 building get empty? or [ list-syntax-error ] when ;
132 : (parse-list-literal) ( right-of-dot? -- )
134 { "}" [ drop +nil+ , ] }
135 { "." [ ?list-syntax-error t (parse-list-literal) ] }
137 parse-datum dup parsing-word? [
138 V{ } clone swap execute-parsing first
140 , [ "}" expect ] [ f (parse-list-literal) ] if
144 : parse-list-literal ( -- list )
145 [ f (parse-list-literal) ] { } make items>list ;
149 SYNTAX: L{ parse-list-literal suffix! ;