diff --git a/README.WIN32.txt b/README.WIN32.txt new file mode 100644 index 0000000000..0456ad39ff --- /dev/null +++ b/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 + + factor.exe boot.image.le32 +... Files are loaded and factor.image is written. + + factor.exe factor.image +... Factor starts the SDL console now. diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 47d3336909..0fcbe52aae 100644 --- a/library/bootstrap/image.factor +++ b/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 [ - nip - ] [ - drop "Missing DEFER: " word-error - ] ifte ; + [ "Missing DEFER: " word-error ] ?unless ; : fixup-word ( word -- offset ) - dup pooled-object dup [ - nip - ] [ - drop "Not in image: " word-error - ] ifte ; + dup pooled-object [ "Not in image: " word-error ] ?unless ; : 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 [ - nip - ] [ - drop dup emit-string dup >r pool-object r> - ] ifte ; + dup pooled-object [ + dup emit-string dup >r pool-object r> + ] ?unless ; ( 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 [ - nip - ] [ - drop [ dup emit-vector [ pool-object ] keep ] keep - rehash - ] ifte ; + dup pooled-object [ + [ dup emit-vector [ pool-object ] keep ] keep rehash + ] ?unless ; ( End of the image ) diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index f6c854405b..515e2dee8c 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -53,11 +53,7 @@ USE: console "smart-terminal" on "verbose-compile" on "compile" on - os "win32" = [ - "sdl" "shell" set - ] [ - "ansi" "shell" set - ] ifte ; + os "win32" = "sdl" "ansi" ? "shell" set ; : warm-boot ( -- ) #! A fully bootstrapped image has this as the boot diff --git a/library/combinators.factor b/library/combinators.factor index 394b8c981c..2c83e2a7c1 100644 --- a/library/combinators.factor +++ b/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 diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor index 20bafabaef..3aae8cf27b 100644 --- a/library/compiler/alien-types.factor +++ b/library/compiler/alien-types.factor @@ -72,11 +72,9 @@ USE: words : c-type ( name -- type ) global [ - dup "c-types" get hash dup [ - nip - ] [ - drop "No such C type: " swap cat2 throw f - ] ifte + dup "c-types" get hash [ + "No such C type: " swap cat2 throw f + ] ?unless ] bind ; : size ( name -- size ) diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor index 9ed835805c..f279a60400 100644 --- a/library/compiler/assembler.factor +++ b/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 [ - nip - ] [ - drop [ + dup interned-literals get hash [ + [ 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 diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 72a7bd5b2a..644f6171c5 100644 --- a/library/compiler/generator.factor +++ b/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 [ - nip call + unswons dup "generator" word-property [ + call ] [ "No generator" throw - ] ifte ; + ] ?ifte ; : generate-code ( word linear -- length ) compiled-offset >r diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index b3b510bbeb..f6fca61b5a 100644 --- a/library/compiler/xt.factor +++ b/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 diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 2cbdd9c364..5914b660ff 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -191,14 +191,14 @@ SYMBOL: object #! error if this is impossible. over builtin-supertypes over builtin-supertypes - intersection dup [ - nip nip lookup-union + intersection [ + 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 diff --git a/library/inference/branches.factor b/library/inference/branches.factor index e30e0310cf..3e725e40e1 100644 --- a/library/inference/branches.factor +++ b/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 [ - nip - ] [ - drop vector-clone [ dup cloned [ acons ] change ] keep - ] ifte ; + dup cloned get assoc [ + vector-clone [ dup cloned [ acons ] change ] keep + ] ?unless ; : deep-clone-vector ( vector -- vector ) #! Clone a vector of vectors. diff --git a/library/inference/words.factor b/library/inference/words.factor index 5f002a098f..cc013eb1ed 100644 --- a/library/inference/words.factor +++ b/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 - ] ifte ; + consume/produce + ] ifte* ; : no-effect ( word -- ) "Unknown stack effect: " swap word-name cat2 throw ; diff --git a/library/namespaces.factor b/library/namespaces.factor index c1f6ca523e..d5ab7f413c 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -79,11 +79,11 @@ USE: vectors : (get) ( var ns -- value ) #! Internal word for searching the namestack. dup [ - 2dup car hash* dup [ - nip nip cdr ( found ) + 2dup car hash* [ + nip cdr ( found ) ] [ - drop cdr (get) ( keep looking ) - ] ifte + cdr (get) ( keep looking ) + ] ?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 [ - nip - ] [ - drop >r dup r> set - ] ifte ; + dup namespace hash [ >r dup r> set ] ?unless ; : change ( var quot -- ) #! Execute the quotation with the variable value on the diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 4322ea64ec..6518079173 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -46,11 +46,7 @@ USE: unparser ! immediately. Otherwise it is appended to the parse tree. : parsing? ( word -- ? ) - dup word? [ - "parsing" word-property - ] [ - drop f - ] ifte ; + dup word? [ "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 [ - nip - ] [ - drop str>number - ] ifte + dup "use" get search [ str>number ] ?unless ] 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 [ - "Expected " swap cat2 throw - ] [ - drop - ] ifte ; + dup scan = [ drop ] [ "Expected " swap cat2 throw ] ifte ; : parsed ( obj -- ) over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ; diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index 16e013b377..1366b0e45b 100644 --- a/library/syntax/unparser.factor +++ b/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 [ - nip - ] [ - drop ch>unicode-escape - ] ifte + dup ch>ascii-escape [ ch>unicode-escape ] ?unless ] unless ; M: string unparse ( str -- str ) diff --git a/library/test/combinators.factor b/library/test/combinators.factor index f6f2dce321..fd8eb776bf 100644 --- a/library/test/combinators.factor +++ b/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 diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 5f5748d84a..ae65b3039b 100644 --- a/library/tools/interpreter.factor +++ b/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 [ - nip call + dup "meta-word" word-property [ + 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 [ - nip call - ] [ - drop host-word - ] ifte ; + dup "meta-word" word-property [ call ] [ host-word ] ?ifte ; : do-1 ( obj -- ) dup word? [ meta-word-1 ] [ push-d ] ifte ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 71bedb18fa..9b4ad2c544 100644 --- a/library/vocabularies.factor +++ b/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 [ - nip nip ( found ) - ] [ - drop cdr search ( check next ) - ] ifte + 2dup car (search) [ nip ] [ cdr search ] ?ifte ] [ - 2drop f ( not found ) + 2drop f ] ifte ; : ( 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. diff --git a/version.factor b/version.factor index 91a69b512b..88f8a80f94 100644 --- a/version.factor +++ b/version.factor @@ -1,2 +1,2 @@ IN: kernel -: version "0.71" ; +: version "0.72" ;