From 81d39d8edaf6246689082c473acc89f8f4dfeb37 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 13 Feb 2023 23:25:52 -0600
Subject: [PATCH] kernel: redo ?if to ?if-old, add ?if ?when ?unless

---
 core/kernel/kernel-tests.factor | 14 ++++++++++----
 core/kernel/kernel.factor       | 18 +++++++++++++++++-
 2 files changed, 27 insertions(+), 5 deletions(-)

diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 4384b0ab39..af3be9b066 100644
--- 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 97e65c95a3..8bd569adba 100644
--- 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
 
-- 
2.34.1