add ?at, tests, documentation

core/assocs/assocs-docs.factor

@@ -58,6 +58,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
 "Utility operations built up from the " { $link "assocs-protocol" } ":"
 { $subsection key? }
 { $subsection at }
+{ $subsection ?at }
 { $subsection assoc-empty? }
 { $subsection keys }
 { $subsection values }
@@ -188,12 +189,16 @@ HELP: key?
 { $values { "key" object } { "assoc" assoc } { "?" "a boolean" } }
 { $description "Tests if an assoc contains a key." } ;
 
-{ at at* key? } related-words
+{ at at* key? ?at } related-words
 
 HELP: at
 { $values { "key" "an object" } { "assoc" assoc } { "value/f" "the value associated to the key, or " { $link f } " if the key is not present in the assoc" } }
 { $description "Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to " { $link f } "; if the difference is important, use " { $link at* } "." } ;
 
+HELP: ?at
+{ $values { "key" "an object" } { "assoc" assoc } { "value/key" "the value associated to the key, or the key if the key is not present in the assoc" } { "?" "a boolean" } }
+{ $description "Looks up the value associated with a key. If the key was not present, an error can be thrown without extra stack shuffling. This word handles assocs that store " { $link f } "." } ;
+
 HELP: assoc-each
 { $values { "assoc" assoc } { "quot" { $quotation "( key value -- )" } } }
 { $description "Applies a quotation to each entry in the assoc." }

core/assocs/assocs-tests.factor

@@ -138,4 +138,7 @@ unit-test
         { "c" [ 3 ] }
         { "d" [ 4 ] }
     } [ nip first even? ] assoc-partition
-] unit-test
+] unit-test
+
+[ 1 f ] [ 1 H{ } ?at ] unit-test
+[ 2 t ] [ 1 H{ { 1 2 } } ?at ] unit-test

core/assocs/assocs.factor

@@ -19,6 +19,9 @@ GENERIC: >alist ( assoc -- newassoc )
 
 M: assoc assoc-like drop ;
 
+: ?at ( key assoc -- value/key ? )
+    dupd at* [ [ nip ] [ drop ] if ] keep ; inline
+
 <PRIVATE
 
 : (assoc-each) ( assoc quot -- seq quot' )
@@ -36,7 +39,7 @@ M: assoc assoc-like drop ;
     [ first = ] with find swap ; inline
 
 : substituter ( assoc -- quot )
-    [ dupd at* [ nip ] [ drop ] if ] curry ; inline
+    [ ?at drop ] curry ; inline
 
 : with-assoc ( assoc quot: ( value key -- assoc ) -- quot: ( key value -- ) )
     curry [ swap ] prepose ; inline
@@ -80,7 +83,7 @@ PRIVATE>
     at* drop ; inline
 
 : at-default ( key assoc -- value/key )
-    2dup at* [ 2nip ] [ 2drop ] if ; inline
+    ?at drop ; inline
 
 M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     [ dup assoc-size ] dip new-assoc