Check in core/dlists

release
Doug Coleman 2007-11-05 01:43:29 -06:00
parent b8561fdc1d
commit 6c8808dd8d
1 changed files with 25 additions and 22 deletions

View File

@ -8,12 +8,12 @@ TUPLE: dlist front back length ;
dlist construct-empty
0 over set-dlist-length ;
: dlist-empty? ( dlist -- ? ) dlist-front not ;
<PRIVATE
TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node
: dlist-empty? ( dlist -- ? ) dlist-front not ;
: inc-length ( dlist -- )
[ dlist-length 1+ ] keep set-dlist-length ; inline
@ -42,6 +42,24 @@ C: <dlist-node> dlist-node
: set-front-to-back ( dlist -- )
dup dlist-front
[ drop ] [ dup dlist-back swap set-dlist-front ] if ;
: (dlist-find-node) ( quot dlist-node -- node/f ? )
dup dlist-node-obj pick dupd call [
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ;
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
: (dlist-each-node) ( quot dlist -- )
over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ;
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
PRIVATE>
: push-front ( obj dlist -- )
@ -78,16 +96,6 @@ PRIVATE>
: pop-back* ( dlist -- ) pop-back drop ;
: (dlist-find-node) ( quot dlist-node -- node/f ? )
dup dlist-node-obj pick dupd call [
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ;
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
: dlist-find ( quot dlist -- obj/f ? )
dlist-find-node dup [ >r dlist-node-obj r> ] when ;
@ -102,20 +110,15 @@ PRIVATE>
dec-length ] }
} cond ;
: delete-node ( quot dlist -- obj/f )
: delete-node* ( quot dlist -- obj/f ? )
tuck dlist-find-node [
[ (delete-node) ] keep [ dlist-node-obj ] [ f ] if*
[ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
] [
2drop f
2drop f f
] if ;
: (dlist-each-node) ( quot dlist -- )
over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ;
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
: delete-node ( quot dlist -- obj/f )
delete-node* drop ;
: dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline