sequences: define ?first and ?second.

db4
John Benediktsson 2011-10-13 12:53:46 -07:00
parent fb178b19a3
commit 3207244c60
15 changed files with 28 additions and 19 deletions

View File

@ -152,7 +152,7 @@ ERROR: no-defined-persistent object ;
: select-tuple ( query/tuple -- tuple/f ) : select-tuple ( query/tuple -- tuple/f )
>query 1 >>limit [ tuple>> ] [ query>statement ] bi >query 1 >>limit [ tuple>> ] [ query>statement ] bi
do-select [ f ] [ first ] if-empty ; do-select ?first ;
: count-tuples ( query/tuple -- n ) : count-tuples ( query/tuple -- n )
>query [ tuple>> ] [ <count-statement> ] bi do-count >query [ tuple>> ] [ <count-statement> ] bi do-count

View File

@ -82,8 +82,6 @@ DEFER: (parse-paragraph)
[ [ parse-paragraph ] or-simple-title link boa ] if [ [ parse-paragraph ] or-simple-title link boa ] if
] dip [ (parse-paragraph) cons ] [ 1list ] if* ; ] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
: ?first ( seq -- elt ) 0 swap ?nth ;
: parse-big-link ( before after -- link rest ) : parse-big-link ( before after -- link rest )
dup ?first CHAR: [ = dup ?first CHAR: [ =
[ parse-link ] [ parse-link ]

View File

@ -277,7 +277,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- )
229 server-response ; 229 server-response ;
: handle-MDTM ( obj -- ) : handle-MDTM ( obj -- )
tokenized>> 1 swap ?nth [ tokenized>> ?second [
fixup-relative-path fixup-relative-path
dup file-info dup directory? [ dup file-info dup directory? [
drop not-a-plain-file drop not-a-plain-file
@ -300,7 +300,7 @@ ERROR: no-directory-permissions ;
"Failed to change directory." 553 server-response ; "Failed to change directory." 553 server-response ;
: handle-CWD ( obj -- ) : handle-CWD ( obj -- )
tokenized>> 1 swap ?nth [ tokenized>> ?second [
fixup-relative-path fixup-relative-path
dup can-serve-directory? [ dup can-serve-directory? [
set-current-directory set-current-directory

View File

@ -70,7 +70,7 @@ CONSTANT: hat-switch-matching-hash
buttons-matching-hash device-elements-matching length ; buttons-matching-hash device-elements-matching length ;
: ?axis ( device hash -- axis/f ) : ?axis ( device hash -- axis/f )
device-elements-matching [ f ] [ first ] if-empty ; device-elements-matching ?first ;
: ?x-axis ( device -- ? ) : ?x-axis ( device -- ? )
x-axis-matching-hash ?axis ; x-axis-matching-hash ?axis ;

View File

@ -26,6 +26,6 @@ M: merged virtual@ ( n seq -- n' seq' )
seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline
M: merged virtual-exemplar ( merged -- seq ) M: merged virtual-exemplar ( merged -- seq )
seqs>> [ f ] [ first ] if-empty ; inline seqs>> ?first ; inline
INSTANCE: merged virtual-sequence INSTANCE: merged virtual-sequence

View File

@ -15,8 +15,7 @@ C: <word> word
[ append ] [ [ words-length ] bi@ ] 2bi <element> ; [ append ] [ [ words-length ] bi@ ] 2bi <element> ;
: ?first2 ( seq -- first/f second/f ) : ?first2 ( seq -- first/f second/f )
[ 0 swap ?nth ] [ ?first ] [ ?second ] bi ;
[ 1 swap ?nth ] bi ;
: split-words ( seq -- half-elements ) : split-words ( seq -- half-elements )
[ [ break?>> ] bi@ = ] monotonic-split ; [ [ break?>> ] bi@ = ] monotonic-split ;

View File

@ -83,8 +83,6 @@ M: closer process
! this does *not* affect the contents of the stack ! this does *not* affect the contents of the stack
[ notags ] unless* ; [ notags ] unless* ;
: ?first ( seq -- elt/f ) 0 swap ?nth ;
: get-prolog ( seq -- prolog ) : get-prolog ( seq -- prolog )
{ "" } ?head drop { "" } ?head drop
?first dup prolog? ?first dup prolog?

View File

@ -179,6 +179,14 @@ HELP: ?nth
{ $values { "n" "an integer" } { "seq" sequence } { "elt/f" "an object or " { $link f } } } { $values { "n" "an integer" } { "seq" sequence } { "elt/f" "an object or " { $link f } } }
{ $description "A forgiving version of " { $link nth } ". If the index is out of bounds, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ; { $description "A forgiving version of " { $link nth } ". If the index is out of bounds, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
HELP: ?first
{ $values { "seq" sequence } { "elt/f" "an object or " { $link f } } }
{ $description "A forgiving version of " { $link first } ". If the sequence is empty, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
HELP: ?second
{ $values { "seq" sequence } { "elt/f" "an object or " { $link f } } }
{ $description "A forgiving version of " { $link second } ". If the sequence has less than two elements, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
HELP: nth-unsafe HELP: nth-unsafe
{ $values { "n" "an integer" } { "seq" sequence } { "elt" object } } { $values { "n" "an integer" } { "seq" sequence } { "elt" object } }
{ $contract "Unsafe variant of " { $link nth } " that does not perform bounds checks." } ; { $contract "Unsafe variant of " { $link nth } " that does not perform bounds checks." } ;

View File

@ -241,6 +241,10 @@ unit-test
[ -3 10 iota nth ] must-fail [ -3 10 iota nth ] must-fail
[ 11 10 iota nth ] must-fail [ 11 10 iota nth ] must-fail
[ f ] [ f ?first ] unit-test
[ f ] [ { } ?first ] unit-test
[ 0 ] [ 10 iota ?first ] unit-test
[ -1/0. 0 remove-nth! ] must-fail [ -1/0. 0 remove-nth! ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test

View File

@ -175,6 +175,9 @@ PRIVATE>
: ?nth ( n seq -- elt/f ) : ?nth ( n seq -- elt/f )
2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
: ?first ( seq -- elt/f ) 0 swap ?nth ; inline
: ?second ( seq -- elt/f ) 1 swap ?nth ; inline
MIXIN: virtual-sequence MIXIN: virtual-sequence
GENERIC: virtual-exemplar ( seq -- seq' ) GENERIC: virtual-exemplar ( seq -- seq' )
GENERIC: virtual@ ( n seq -- n' seq' ) GENERIC: virtual@ ( n seq -- n' seq' )

View File

@ -506,7 +506,7 @@ TYPED:: virtual-address-segment ( elf: Elf32/64_Ehdr address -- program-header/f
elf elf-program-headers elf-loadable-segments [ elf elf-program-headers elf-loadable-segments [
[ p_vaddr>> dup ] [ p_memsz>> + ] bi [a,b) [ p_vaddr>> dup ] [ p_memsz>> + ] bi [a,b)
address swap interval-contains? address swap interval-contains?
] filter [ f ] [ first ] if-empty ; ] find nip ;
TYPED:: virtual-address-section ( elf: Elf32/64_Ehdr address -- section-header/f ) TYPED:: virtual-address-section ( elf: Elf32/64_Ehdr address -- section-header/f )
elf address virtual-address-segment :> segment elf address virtual-address-segment :> segment
@ -515,7 +515,7 @@ TYPED:: virtual-address-section ( elf: Elf32/64_Ehdr address -- section-header/f
sections [ sections [
[ sh_offset>> dup ] [ sh_size>> + ] bi [a,b) [ sh_offset>> dup ] [ sh_size>> + ] bi [a,b)
faddress swap interval-contains? faddress swap interval-contains?
] filter [ f ] [ first ] if-empty ; ] find nip ;
TYPED:: elf-segment-data ( elf: Elf32/64_Ehdr header: Elf32/64_Phdr -- uchar-array/f ) TYPED:: elf-segment-data ( elf: Elf32/64_Ehdr header: Elf32/64_Phdr -- uchar-array/f )
header [ p_offset>> elf >c-ptr <displaced-alien> ] [ p_filesz>> ] bi uchar <c-direct-array> ; header [ p_offset>> elf >c-ptr <displaced-alien> ] [ p_filesz>> ] bi uchar <c-direct-array> ;

View File

@ -65,7 +65,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: send-query-1result ( collection assoc -- result ) : send-query-1result ( collection assoc -- result )
<mdb-query-msg> -1 >>return# send-query-plain <mdb-query-msg> -1 >>return# send-query-plain
objects>> [ f ] [ first ] if-empty ; objects>> ?first ;
: send-cmd ( cmd -- result ) : send-cmd ( cmd -- result )
[ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline

View File

@ -240,9 +240,8 @@ M: mdb-cursor find
t >>explain find nip . ; t >>explain find nip . ;
: find-one ( mdb-query-msg -- result/f ) : find-one ( mdb-query-msg -- result/f )
fix-query-collection fix-query-collection 1 >>return#
1 >>return# send-query-plain objects>> send-query-plain objects>> ?first ;
[ f ] [ first ] if-empty ;
: count ( mdb-query-msg -- result ) : count ( mdb-query-msg -- result )
[ count-cmd make-cmd ] dip [ count-cmd make-cmd ] dip

View File

@ -72,7 +72,7 @@ M: summed set-length ( n seq -- )
seqs>> [ set-length ] with each ; seqs>> [ set-length ] with each ;
M: summed virtual-exemplar ( summed -- seq ) M: summed virtual-exemplar ( summed -- seq )
seqs>> [ f ] [ first ] if-empty ; seqs>> ?first ;
: <2summed> ( seq seq -- summed-seq ) 2array <summed> ; : <2summed> ( seq seq -- summed-seq ) 2array <summed> ;
: <3summed> ( seq seq seq -- summed-seq ) 3array <summed> ; : <3summed> ( seq seq seq -- summed-seq ) 3array <summed> ;

View File

@ -72,7 +72,7 @@ MEMO: default-dictionary ( -- counts )
load-dictionary ; load-dictionary ;
: (correct) ( word dictionary -- word/f ) : (correct) ( word dictionary -- word/f )
corrections [ f ] [ first ] if-empty ; corrections ?first ;
: correct ( word -- word/f ) : correct ( word -- word/f )
default-dictionary (correct) ; default-dictionary (correct) ;