122 lines
3.4 KiB
Factor
122 lines
3.4 KiB
Factor
! Copyright (C) 2003, 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: lists USING: generic kernel kernel-internals ;
|
|
|
|
! This file contains vital list-related words that everything
|
|
! else depends on, and is loaded early in bootstrap.
|
|
! lists.factor has everything else.
|
|
|
|
BUILTIN: cons 2
|
|
|
|
: car ( [[ car cdr ]] -- car ) >cons 0 slot ; inline
|
|
: cdr ( [[ car cdr ]] -- cdr ) >cons 1 slot ; inline
|
|
|
|
: swons ( cdr car -- [[ car cdr ]] )
|
|
#! Push a new cons cell. If the cdr is f or a proper list,
|
|
#! has the effect of prepending the car to the cdr.
|
|
swap cons ; inline
|
|
|
|
: uncons ( [[ car cdr ]] -- car cdr )
|
|
#! Push both the head and tail of a list.
|
|
dup car swap cdr ; inline
|
|
|
|
: unit ( a -- [ a ] )
|
|
#! Construct a proper list of one element.
|
|
f cons ; inline
|
|
|
|
: unswons ( [[ car cdr ]] -- cdr car )
|
|
#! Push both the head and tail of a list.
|
|
dup cdr swap car ; inline
|
|
|
|
: 2car ( cons cons -- car car )
|
|
swap car swap car ;
|
|
|
|
: 2cdr ( cons cons -- car car )
|
|
swap cdr swap cdr ;
|
|
|
|
: 2uncons ( cons1 cons2 -- car1 car2 cdr1 cdr2 )
|
|
[ 2car ] 2keep 2cdr ;
|
|
|
|
: last* ( list -- last )
|
|
#! Last cons of a list.
|
|
dup cdr cons? [ cdr last* ] when ;
|
|
|
|
: last ( list -- last )
|
|
#! Last element of a list.
|
|
last* car ;
|
|
|
|
UNION: general-list f cons ;
|
|
|
|
PREDICATE: general-list list ( list -- ? )
|
|
#! Proper list test. A proper list is either f, or a cons
|
|
#! cell whose cdr is a proper list.
|
|
dup [ last* cdr ] when not ;
|
|
|
|
: with ( obj quot elt -- obj quot )
|
|
#! Utility word for each-with, map-with.
|
|
pick pick >r >r swap call r> r> ; inline
|
|
|
|
: all? ( list pred -- ? )
|
|
#! Push if the predicate returns true for each element of
|
|
#! the list.
|
|
over [
|
|
dup >r swap uncons >r swap call [
|
|
r> r> all?
|
|
] [
|
|
r> drop r> drop f
|
|
] ifte
|
|
] [
|
|
2drop t
|
|
] ifte ; inline
|
|
|
|
: all-with? ( obj list pred -- ? )
|
|
swap [ with rot ] all? 2nip ; inline
|
|
|
|
: (each) ( list quot -- list quot )
|
|
>r uncons r> tuck 2slip ; inline
|
|
|
|
: each ( list quot -- )
|
|
#! Push each element of a proper list in turn, and apply a
|
|
#! quotation with effect ( elt -- ) to each element.
|
|
over [ (each) each ] [ 2drop ] ifte ; inline
|
|
|
|
: each-with ( obj list quot -- )
|
|
#! Push each element of a proper list in turn, and apply a
|
|
#! quotation with effect ( obj elt -- ) to each element.
|
|
swap [ with ] each 2drop ; inline
|
|
|
|
: subset ( list quot -- list )
|
|
#! Applies a quotation with effect ( X -- ? ) to each
|
|
#! element of a list; all elements for which the quotation
|
|
#! returned a value other than f are collected in a new
|
|
#! list.
|
|
over [
|
|
over car >r (each)
|
|
rot >r subset r> [ r> swons ] [ r> drop ] ifte
|
|
] [
|
|
drop
|
|
] ifte ; inline
|
|
|
|
: subset-with ( obj list quot -- list )
|
|
swap [ with rot ] subset 2nip ; inline
|
|
|
|
: some? ( list pred -- ? )
|
|
#! Apply predicate with stack effect ( elt -- ? ) to each
|
|
#! element, return remainder of list from first occurrence
|
|
#! where it is true, or return f.
|
|
over [
|
|
dup >r over >r >r car r> call [
|
|
r> r> drop
|
|
] [
|
|
r> cdr r> some?
|
|
] ifte
|
|
] [
|
|
2drop f
|
|
] ifte ; inline
|
|
|
|
: some-with? ( obj list pred -- ? )
|
|
#! Apply predicate with stack effect ( obj elt -- ? ) to
|
|
#! each element, return remainder of list from first
|
|
#! occurrence where it is true, or return f.
|
|
swap [ with rot ] some? 2nip ; inline
|