kernel: redo ?if to ?if-old, add ?if ?when ?unless

diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 4384b0ab3987bb298d3d1ebf21634c4f14a29e95..af3be9b066ff308583df136c537f06f002d5be66 100644 (file)
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -1,8 +1,8 @@
 USING: accessors alien alien.accessors arrays assocs byte-arrays
 continuations debugger grouping io.streams.string kernel
-kernel.private literals locals.backend math memory namespaces
-prettyprint sequences sequences.private tools.test vocabs.loader
-words ;
+kernel.private literals locals.backend math math.parser memory
+namespaces prettyprint sequences sequences.private tools.test
+vocabs.loader words ;
 IN: kernel.tests
 
 { 0 } [ f size ] unit-test
@@ -209,4 +209,10 @@ IN: kernel.tests
 { 2 3 4 1 } [ 1 2 3 4 roll ] unit-test
 { 1 2 3 4 } [ 2 3 4 1 -roll ] unit-test
 
-{ } [ "kernel" reload ] long-unit-test
\ No newline at end of file
+{ } [ "kernel" reload ] long-unit-test
+
+{ 5 } [ "5" [ string>number ] transmute ] unit-test
+{ "5notanumber" } [ "5notanumber" [ string>number ] transmute ] unit-test
+
+{ 10 } [ 5 [ 2 * ] ?transmute ] unit-test
+{ f } [ f [ 2 * ] ?transmute ] unit-test

diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 97e65c95a334d1f60d2189d7c7cda0caca40fcc1..8bd569adba9a57ed2f53efcba002a71cce2ef647 100644 (file)
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -103,10 +103,26 @@ DEFER: if
 : unless* ( ..a ? false: ( ..a -- ..a x ) -- ..a x )
     over [ drop ] [ nip call ] if ; inline
 
+: transmute* ( obj quot: ( obj -- obj/f ) -- new/old changed? )
+    over [ call ] dip over [ drop t ] [ nip f ] if ; inline
+
+: transmute ( obj quot: ( obj -- new/old ) -- new/old ) transmute* drop ; inline
+
+: ?transmute ( obj/f quot -- obj' ) dupd when ; inline
+
 ! Default
-: ?if ( ..a default cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
+: ?if ( ..a obj cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
     pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
 
+: ?when ( ..a obj cond: ( ..a obj -- obj/f ) true: ( ..a cond -- ..b ) -- ..b )
+    [ transmute* ] dip when ; inline
+
+: ?unless ( ..a obj cond: ( ..a obj -- obj/f ) false: ( ..a default -- ..b ) -- ..b )
+    [ transmute* ] dip unless ; inline
+
+: ??if ( ..a obj cond: ( ..a obj -- obj/f ) true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
+    [ transmute* ] 2dip if ; inline
+
 ! Dippers.
 ! Not declared inline because the compiler special-cases them