new ?ifte ?unless ?when combinators

README.WIN32.txt

@@ -0,0 +1,20 @@
+FACTOR ON WINDOWS
+
+The Windows port of Factor requires Windows 2000 or later. If you are
+using Windows 95, 98 or NT, you might be able to get the Unix port of
+Factor running inside Cygwin. Or you might not.
+
+A precompiled factor.exe is included with the download, along with
+SDL.dll and SDL_gfx.dll. The SDL libraries are required for the
+interactive interpreter. Factor does not use the Windows console,
+because it does not support asynchronous I/O.
+
+To run the Windows port, open a DOS prompt and type:
+
+  cd <directory where Factor is installed>
+
+  factor.exe boot.image.le32
+... Files are loaded and factor.image is written.
+
+  factor.exe factor.image
+... Factor starts the SDL console now.

library/bootstrap/image.factor

@@ -215,18 +215,10 @@ M: f ' ( obj -- ptr )
 : transfer-word ( word -- word )
     #! This is a hack. See doc/bootstrap.txt.
     dup dup word-name swap word-vocabulary unit search
-    dup [
+    [ "Missing DEFER: " word-error ] ?unless ;
-        nip
-    ] [
-        drop "Missing DEFER: " word-error
-    ] ifte ;
 
 : fixup-word ( word -- offset )
-    dup pooled-object dup [
+    dup pooled-object [ "Not in image: " word-error ] ?unless ;
-        nip
-    ] [
-        drop "Not in image: " word-error
-    ] ifte ;
 
 : fixup-words ( -- )
     image get [
@@ -272,11 +264,9 @@ M: cons ' ( c -- tagged )
 M: string ' ( string -- pointer )
     #! We pool strings so that each string is only written once
     #! to the image
-    dup pooled-object dup [
+    dup pooled-object [
-        nip
+        dup emit-string dup >r pool-object r>
-    ] [
+    ] ?unless ;
-        drop dup emit-string dup >r pool-object r>
-    ] ifte ;
 
 ( Arrays and vectors )
 
@@ -311,12 +301,9 @@ M: vector ' ( vector -- pointer )
 
 M: hashtable ' ( hashtable -- pointer )
     #! Only hashtables are pooled, not vectors!
-    dup pooled-object dup [
+    dup pooled-object [
-        nip
+        [ dup emit-vector [ pool-object ] keep ] keep rehash
-    ] [
+    ] ?unless ;
-        drop [ dup emit-vector [ pool-object ] keep ] keep
-        rehash
-    ] ifte ;
 
 ( End of the image )
 

library/bootstrap/init-stage2.factor

@@ -53,11 +53,7 @@ USE: console
     "smart-terminal" on
     "verbose-compile" on
     "compile" on
-    os "win32" = [
+    os "win32" = "sdl" "ansi" ? "shell" set ;
-        "sdl" "shell" set
-    ] [
-        "ansi" "shell" set
-    ] ifte ;
 
 : warm-boot ( -- )
     #! A fully bootstrapped image has this as the boot

library/combinators.factor

@@ -95,3 +95,25 @@ IN: kernel
     #!
     #! This combinator will not compile.
     dup slip forever ;
+
+: ?ifte ( default cond true false -- )
+    #! If cond is true, drop default and apply true
+    #! quotation to cond. Otherwise, drop cond, and apply false
+    #! to default.
+    >r >r dup [
+        nip r> r> drop call
+    ] [
+        drop r> drop r> call
+    ] ifte ; inline
+
+: ?when ( default cond true -- )
+    #! If cond is true, drop default and apply true
+    #! quotation to cond. Otherwise, drop cond, and leave
+    #! default on the stack.
+    >r dup [ nip r> call ] [ r> 2drop ] ifte ; inline
+
+: ?unless ( default cond false -- )
+    #! If cond is true, drop default and leave cond on the
+    #! stack. Otherwise, drop default, and apply false
+    #! quotation to default.
+    >r dup [ nip r> drop ] [ drop r> call ] ifte ; inline

library/compiler/alien-types.factor

@@ -72,11 +72,9 @@ USE: words
 
 : c-type ( name -- type )
     global [
-        dup "c-types" get hash dup [
+        dup "c-types" get hash [
-            nip
+            "No such C type: " swap cat2 throw f
-        ] [
+        ] ?unless
-            drop "No such C type: " swap cat2 throw f
-        ] ifte
     ] bind ;
 
 : size ( name -- size )

library/compiler/assembler.factor

@@ -47,16 +47,14 @@ SYMBOL: interned-literals
     compiled-offset cell 2 * align set-compiled-offset ; inline
 
 : intern-literal ( obj -- lit# )
-    dup interned-literals get hash dup [
+    dup interned-literals get hash [
-        nip
+        [
-    ] [
-        drop [
             address
             literal-top set-compiled-cell
             literal-top dup cell + set-literal-top
             dup
         ] keep interned-literals get set-hash
-    ] ifte ;
+    ] ?unless ;
 
 : compile-byte ( n -- )
     compiled-offset set-compiled-byte

library/compiler/generator.factor

@@ -62,11 +62,11 @@ SYMBOL: relocation-table
 
 : generate-node ( [ op | params ] -- )
     #! Generate machine code for a node.
-    unswons dup "generator" word-property dup [
+    unswons dup "generator" word-property [
-        nip call
+        call
     ] [
         "No generator" throw
-    ] ifte ;
+    ] ?ifte ;
 
 : generate-code ( word linear -- length )
     compiled-offset >r

library/compiler/xt.factor

@@ -63,7 +63,7 @@ SYMBOL: compiled-xts
     compiled-xts off ;
 
 : compiled-xt ( word -- xt )
-    dup compiled-xts get assoc [ nip ] [ word-xt ] ifte* ;
+    dup compiled-xts get assoc [ word-xt ] ?unless ;
 
 ! "deferred-xts" is a list of [ where word relative ] pairs; the
 ! xt of word when its done compiling will be written to the

library/generic/generic.factor

@@ -191,14 +191,14 @@ SYMBOL: object
     #! error if this is impossible.
     over builtin-supertypes
     over builtin-supertypes
-    intersection dup [
+    intersection [
-        nip nip lookup-union
+        nip lookup-union
     ] [
-        drop [
+        [
             word-name , " and " , word-name ,
             " do not intersect" ,
         ] make-string throw
-    ] ifte ;
+    ] ?ifte ;
 
 : define-promise ( class -- )
     #! A promise is a word that has no effect during

library/inference/branches.factor

@@ -111,11 +111,9 @@ SYMBOL: cloned
 : deep-clone ( vector -- vector )
     #! Clone a vector if it hasn't already been cloned in this
     #! with-deep-clone scope.
-    dup cloned get assoc dup [
+    dup cloned get assoc [
-        nip
+        vector-clone [ dup cloned [ acons ] change ] keep
-    ] [
+    ] ?unless ;
-        drop vector-clone [ dup cloned [ acons ] change ] keep
-    ] ifte ;
 
 : deep-clone-vector ( vector -- vector )
     #! Clone a vector of vectors.

library/inference/words.factor

@@ -69,11 +69,11 @@ USE: prettyprint
     #! either execute the word in the meta interpreter (if it is
     #! side-effect-free and all parameters are literal), or
     #! simply apply its stack effect to the meta-interpreter.
-    over "infer" word-property dup [
+    over "infer" word-property [
         swap car ensure-d call drop
     ] [
-        drop consume/produce
+        consume/produce
-    ] ifte ;
+    ] ifte* ;
 
 : no-effect ( word -- )
     "Unknown stack effect: " swap word-name cat2 throw ;

library/namespaces.factor

@@ -79,11 +79,11 @@ USE: vectors
 : (get) ( var ns -- value )
     #! Internal word for searching the namestack.
     dup [
-        2dup car hash* dup [
+        2dup car hash* [
-            nip nip cdr ( found )
+            nip cdr ( found )
         ] [
-            drop cdr (get) ( keep looking )
+            cdr (get) ( keep looking )
-        ] ifte
+        ] ?ifte
     ] [
         2drop f
     ] ifte ;
@@ -99,11 +99,7 @@ USE: vectors
 : nest ( variable -- hash )
     #! If the variable is set in the current namespace, return
     #! its value, otherwise set its value to a new namespace.
-    dup namespace hash dup [
+    dup namespace hash [ >r <namespace> dup r> set ] ?unless ;
-        nip
-    ] [
-        drop >r <namespace> dup r> set
-    ] ifte ;
 
 : change ( var quot -- )
     #! Execute the quotation with the variable value on the

library/syntax/parser.factor

@@ -46,11 +46,7 @@ USE: unparser
 ! immediately. Otherwise it is appended to the parse tree.
 
 : parsing? ( word -- ? )
-    dup word? [
+    dup word? [ "parsing" word-property ] [ drop f ] ifte ;
-        "parsing" word-property
-    ] [
-        drop f
-    ] ifte ;
 
 : end? ( -- ? )
     "col" get "line" get str-length >= ;
@@ -119,11 +115,7 @@ USE: unparser
 
 : scan-word ( -- obj )
     scan dup [
-        dup "use" get search dup [
+        dup "use" get search [ str>number ] ?unless
-            nip
-        ] [
-            drop str>number
-        ] ifte
     ] when ;
 
 : parsed| ( parsed parsed obj -- parsed )
@@ -131,11 +123,7 @@ USE: unparser
     >r unswons r> cons swap [ swons ] each swons ;
 
 : expect ( word -- )
-    dup scan = not [
+    dup scan = [ drop ] [ "Expected " swap cat2 throw ] ifte ;
-        "Expected " swap cat2 throw
-    ] [
-        drop
-    ] ifte ;
 
 : parsed ( obj -- )
     over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ;

library/syntax/unparser.factor

@@ -117,11 +117,7 @@ M: complex unparse ( num -- str )
 
 : unparse-ch ( ch -- ch/str )
     dup quotable? [
-        dup ch>ascii-escape dup [
+        dup ch>ascii-escape [ ch>unicode-escape ] ?unless
-            nip
-        ] [
-            drop ch>unicode-escape
-        ] ifte
     ] unless ;
 
 M: string unparse ( str -- str )

library/test/combinators.factor

@@ -2,6 +2,8 @@ IN: scratchpad
 USE: kernel
 USE: math
 USE: test
+USE: stdio
+USE: prettyprint
 
 [ slip ] unit-test-fails
 [ 1 slip ] unit-test-fails
@@ -25,3 +27,9 @@ USE: test
 
 [ 0 ] [ f [ 0 ] unless* ] unit-test
 [ t ] [ t [ "Hello" ] unless* ] unit-test
+
+[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?ifte ] with-string ] unit-test
+[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?ifte ] with-string ] unit-test
+[ "4\n" ] [ [ 3 4 [ . ] ?when ] with-string ] unit-test
+[ 3 ] [ 3 f [ . ] ?when ] unit-test
+[ 3 ] [ 3 t [ . ] ?unless ] unit-test

library/tools/interpreter.factor

@@ -94,25 +94,21 @@ SYMBOL: meta-cf
     meta-cf [ [ push-r ] when* ] change ;
 
 : meta-word ( word -- )
-    dup "meta-word" word-property dup [
+    dup "meta-word" word-property [
-        nip call
+        call
     ] [
-        drop dup compound? [
+        dup compound? [
             word-parameter meta-call
         ] [
             host-word
         ] ifte
-    ] ifte ;
+    ] ?ifte ;
 
 : do ( obj -- )
     dup word? [ meta-word ] [ push-d ] ifte ;
 
 : meta-word-1 ( word -- )
-    dup "meta-word" word-property dup [
+    dup "meta-word" word-property [ call ] [ host-word ] ?ifte ;
-        nip call
-    ] [
-        drop host-word
-    ] ifte ;
 
 : do-1 ( obj -- )
     dup word? [ meta-word-1 ] [ push-d ] ifte ;

library/vocabularies.factor

@@ -63,13 +63,9 @@ USE: strings
 : search ( name list -- word )
     #! Search for a word in a list of vocabularies.
     dup [
-        2dup car (search) dup [
+        2dup car (search) [ nip ] [ cdr search ] ?ifte
-            nip nip ( found )
-        ] [
-            drop cdr search ( check next )
-        ] ifte
     ] [
-        2drop f ( not found )
+        2drop f
     ] ifte ;
 
 : <plist> ( name vocab -- plist )
@@ -91,7 +87,7 @@ USE: strings
     #! Create a new word in a vocabulary. If the vocabulary
     #! already contains the word, the existing instance is
     #! returned.
-    2dup (search) [ nip nip ] [ (create) dup reveal ] ifte* ;
+    2dup (search) [ nip ] [ (create) dup reveal ] ?ifte ;
 
 : forget ( word -- )
     #! Remove a word definition.

version.factor

@@ -1,2 +1,2 @@
 IN: kernel
-: version "0.71" ;
+: version "0.72" ;