Merge branch 'master' of /Users/slava/factor/

README.txt

@@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
 
 * Compiling the Factor VM
 
-The Factor runtime is written in GNU C++, and is built with GNU make and
-gcc.
-
 Factor supports various platforms. For an up-to-date list, see
 <http://factorcode.org>.
 
-Factor requires gcc 3.4 or later.
+The Factor VM is written in C++ and uses GNU extensions. When compiling
-
+with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
-On x86, Factor /will not/ build using gcc 3.3 or earlier.
+uses std::tr1::unordered_map which is shipped as part of GCC.
-
-If you are using gcc 4.3, you might get an unusable Factor binary unless
-you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
-arguments for make.
 
 Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
 
 * Bootstrapping the Factor image
 
-Once you have compiled the Factor runtime, you must bootstrap the Factor
+Once you have compiled the Factor VM, you must bootstrap the Factor
 system using the image that corresponds to your CPU architecture.
 
 Boot images can be obtained from <http://factorcode.org/images/latest/>.
@@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
 
 Then bootstrap with the following switches:
 
-  ./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
+  ./factor -i=boot.<cpu>.image -ui-backend=x11
 
 Now if $DISPLAY is set, running ./factor will start the UI.
 
@@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
 The Factor source tree is organized as follows:
 
   build-support/ - scripts used for compiling Factor
-  vm/ - sources for the Factor VM, written in C++
+  vm/ - Factor VM
   core/ - Factor core library
   basis/ - Factor basis library, compiler, tools
   extra/ - more libraries and applications

basis/alien/arrays/arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.strings alien.c-types alien.accessors alien.structs
 arrays words sequences math kernel namespaces fry libc cpu.architecture
-io.encodings.utf8 io.encodings.utf16n ;
+io.encodings.utf8 ;
 IN: alien.arrays
 
 UNION: value-type array struct-type ;
@@ -95,5 +95,4 @@ M: string-type c-type-setter
 
 { "char*" utf8 } "char*" typedef
 "char*" "uchar*" typedef
-{ "char*" utf16n } "wchar_t*" typedef
 

basis/alien/c-types/c-types.factor

@@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- )
     [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
-: c-bool> ( int -- ? )
+: >c-bool ( ? -- int ) 1 0 ? ; inline
-    0 = not ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
 
 : define-primitive-type ( type name -- )
     [ typedef ]
@@ -409,10 +410,10 @@ CONSTANT: primitive-types
     "uchar" define-primitive-type
 
     <c-type>
-        [ alien-unsigned-4 zero? not ] >>getter
+        [ alien-unsigned-1 c-bool> ] >>getter
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
+        [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
-        4 >>size
+        1 >>size
-        4 >>align
+        1 >>align
         "box_boolean" >>boxer
         "to_boolean" >>unboxer
     "bool" define-primitive-type

basis/alien/libraries/libraries.factor

@@ -5,7 +5,7 @@ IN: alien.libraries
 
 : dlopen ( path -- dll ) native-string>alien (dlopen) ;
 
-: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
+: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
 
 SYMBOL: libraries
 

basis/base64/base64-tests.factor

@@ -4,7 +4,7 @@ IN: base64.tests
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
 ] unit-test
-[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
+[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
 [ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
 [ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
 [ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test

basis/bootstrap/compiler/compiler.factor

@@ -41,7 +41,7 @@ nl
 ! which are also quick to compile are replaced by
 ! compiled definitions as soon as possible.
 {
-    roll -roll declare not
+    not
 
     array? hashtable? vector?
     tuple? sbuf? tombstone?

basis/bootstrap/image/image.factor

@@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs
 vocabs.loader source-files definitions debugger quotations.private
 sequences.private combinators math.order math.private accessors
 slots.private generic.single.private compiler.units compiler.constants
-fry ;
+fry bootstrap.image.syntax ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
 
 M: integer (eql?) = ;
 
+M: float (eql?)
+    over float? [ fp-bitwise= ] [ 2drop f ] if ;
+
 M: sequence (eql?)
     over sequence? [
         2dup [ length ] bi@ =
@@ -93,24 +96,19 @@ CONSTANT: -1-offset             9
 
 SYMBOL: sub-primitives
 
-SYMBOL: jit-define-rc
+SYMBOL: jit-relocations
-SYMBOL: jit-define-rt
-SYMBOL: jit-define-offset
 
-: compute-offset ( -- offset )
+: compute-offset ( rc -- offset )
-    building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
+    [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
 
 : jit-rel ( rc rt -- )
-    jit-define-rt set
+    over compute-offset 3array jit-relocations get push-all ;
-    jit-define-rc set
-    compute-offset jit-define-offset set ;
 
-: make-jit ( quot -- quad )
+: make-jit ( quot -- jit-data )
     [
+        V{ } clone jit-relocations set
         call( -- )
-        jit-define-rc get
+        jit-relocations get >array
-        jit-define-rt get
-        jit-define-offset get 3array
     ] B{ } make prefix ;
 
 : jit-define ( quot name -- )
@@ -128,98 +126,59 @@ SYMBOL: big-endian
 ! Bootstrap architecture name
 SYMBOL: architecture
 
-! Bootstrap global namesapce
+RESET
-SYMBOL: bootstrap-global
 
 ! Boot quotation, set in stage1.factor
-SYMBOL: bootstrap-boot-quot
+USERENV: bootstrap-boot-quot 20
+
+! Bootstrap global namesapce
+USERENV: bootstrap-global 21
 
 ! JIT parameters
-SYMBOL: jit-prolog
+USERENV: jit-prolog 23
-SYMBOL: jit-primitive-word
+USERENV: jit-primitive-word 24
-SYMBOL: jit-primitive
+USERENV: jit-primitive 25
-SYMBOL: jit-word-jump
+USERENV: jit-word-jump 26
-SYMBOL: jit-word-call
+USERENV: jit-word-call 27
-SYMBOL: jit-push-immediate
+USERENV: jit-word-special 28
-SYMBOL: jit-if-word
+USERENV: jit-if-word 29
-SYMBOL: jit-if-1
+USERENV: jit-if 30
-SYMBOL: jit-if-2
+USERENV: jit-epilog 31
-SYMBOL: jit-dip-word
+USERENV: jit-return 32
-SYMBOL: jit-dip
+USERENV: jit-profiling 33
-SYMBOL: jit-2dip-word
+USERENV: jit-push-immediate 34
-SYMBOL: jit-2dip
+USERENV: jit-dip-word 35
-SYMBOL: jit-3dip-word
+USERENV: jit-dip 36
-SYMBOL: jit-3dip
+USERENV: jit-2dip-word 37
-SYMBOL: jit-execute-word
+USERENV: jit-2dip 38
-SYMBOL: jit-execute-jump
+USERENV: jit-3dip-word 39
-SYMBOL: jit-execute-call
+USERENV: jit-3dip 40
-SYMBOL: jit-epilog
+USERENV: jit-execute-word 41
-SYMBOL: jit-return
+USERENV: jit-execute-jump 42
-SYMBOL: jit-profiling
+USERENV: jit-execute-call 43
-SYMBOL: jit-save-stack
 
 ! PIC stubs
-SYMBOL: pic-load
+USERENV: pic-load 47
-SYMBOL: pic-tag
+USERENV: pic-tag 48
-SYMBOL: pic-hi-tag
+USERENV: pic-hi-tag 49
-SYMBOL: pic-tuple
+USERENV: pic-tuple 50
-SYMBOL: pic-hi-tag-tuple
+USERENV: pic-hi-tag-tuple 51
-SYMBOL: pic-check-tag
+USERENV: pic-check-tag 52
-SYMBOL: pic-check
+USERENV: pic-check 53
-SYMBOL: pic-hit
+USERENV: pic-hit 54
-SYMBOL: pic-miss-word
+USERENV: pic-miss-word 55
+USERENV: pic-miss-tail-word 56
 
 ! Megamorphic dispatch
-SYMBOL: mega-lookup
+USERENV: mega-lookup 57
-SYMBOL: mega-lookup-word
+USERENV: mega-lookup-word 58
-SYMBOL: mega-miss-word
+USERENV: mega-miss-word 59
 
 ! Default definition for undefined words
-SYMBOL: undefined-quot
+USERENV: undefined-quot 60
-
-: userenvs ( -- assoc )
-    H{
-        { bootstrap-boot-quot 20 }
-        { bootstrap-global 21 }
-        { jit-prolog 23 }
-        { jit-primitive-word 24 }
-        { jit-primitive 25 }
-        { jit-word-jump 26 }
-        { jit-word-call 27 }
-        { jit-if-word 28 }
-        { jit-if-1 29 }
-        { jit-if-2 30 }
-        { jit-epilog 33 }
-        { jit-return 34 }
-        { jit-profiling 35 }
-        { jit-push-immediate 36 }
-        { jit-save-stack 38 }
-        { jit-dip-word 39 }
-        { jit-dip 40 }
-        { jit-2dip-word 41 }
-        { jit-2dip 42 }
-        { jit-3dip-word 43 }
-        { jit-3dip 44 }
-        { jit-execute-word 45 }
-        { jit-execute-jump 46 }
-        { jit-execute-call 47 }
-        { pic-load 48 }
-        { pic-tag 49 }
-        { pic-hi-tag 50 }
-        { pic-tuple 51 }
-        { pic-hi-tag-tuple 52 }
-        { pic-check-tag 53 }
-        { pic-check 54 }
-        { pic-hit 55 }
-        { pic-miss-word 56 }
-        { mega-lookup 57 }
-        { mega-lookup-word 58 }
-        { mega-miss-word 59 }
-        { undefined-quot 60 }
-    } ; inline
 
 : userenv-offset ( symbol -- n )
-    userenvs at header-size + ;
+    userenvs get at header-size + ;
 
 : emit ( cell -- ) image get push ;
 
@@ -351,7 +310,8 @@ M: f '
                     [ vocabulary>> , ]
                     [ def>> , ]
                     [ props>> , ]
-                    [ direct-entry-def>> , ] ! direct-entry-def
+                    [ pic-def>> , ]
+                    [ pic-tail-def>> , ]
                     [ drop 0 , ] ! count
                     [ word-sub-primitive , ]
                     [ drop 0 , ] ! xt
@@ -488,7 +448,6 @@ M: quotation '
         array>> '
         quotation [
             emit ! array
-            f ' emit ! compiled
             f ' emit ! cached-effect
             f ' emit ! cache-counter
             0 emit ! xt
@@ -510,11 +469,7 @@ M: quotation '
         class<=-cache class-not-cache classes-intersect-cache
         class-and-cache class-or-cache next-method-quot-cache
     } [ H{ } clone ] H{ } map>assoc assoc-union
-    bootstrap-global set
+    bootstrap-global set ;
-    bootstrap-global emit-userenv ;
-
-: emit-boot-quot ( -- )
-    bootstrap-boot-quot emit-userenv ;
 
 : emit-jit-data ( -- )
     \ if jit-if-word set
@@ -524,46 +479,13 @@ M: quotation '
     \ 3dip jit-3dip-word set
     \ (execute) jit-execute-word set
     \ inline-cache-miss \ pic-miss-word set
+    \ inline-cache-miss-tail \ pic-miss-tail-word set
     \ mega-cache-lookup \ mega-lookup-word set
     \ mega-cache-miss \ mega-miss-word set
-    [ undefined ] undefined-quot set
+    [ undefined ] undefined-quot set ;
-    {
+
-        jit-prolog
+: emit-userenvs ( -- )
-        jit-primitive-word
+    userenvs get keys [ emit-userenv ] each ;
-        jit-primitive
-        jit-word-jump
-        jit-word-call
-        jit-push-immediate
-        jit-if-word
-        jit-if-1
-        jit-if-2
-        jit-dip-word
-        jit-dip
-        jit-2dip-word
-        jit-2dip
-        jit-3dip-word
-        jit-3dip
-        jit-execute-word
-        jit-execute-jump
-        jit-execute-call
-        jit-epilog
-        jit-return
-        jit-profiling
-        jit-save-stack
-        pic-load
-        pic-tag
-        pic-hi-tag
-        pic-tuple
-        pic-hi-tag-tuple
-        pic-check-tag
-        pic-check
-        pic-hit
-        pic-miss-word
-        mega-lookup
-        mega-lookup-word
-        mega-miss-word
-        undefined-quot
-    } [ emit-userenv ] each ;
 
 : fixup-header ( -- )
     heap-size data-heap-size-offset fixup ;
@@ -580,8 +502,8 @@ M: quotation '
     emit-jit-data
     "Serializing global namespace..." print flush
     emit-global
-    "Serializing boot quotation..." print flush
+    "Serializing user environment..." print flush
-    emit-boot-quot
+    emit-userenvs
     "Performing word fixups..." print flush
     fixup-words
     "Performing header fixups..." print flush

basis/bootstrap/image/syntax/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/bootstrap/image/syntax/syntax.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel namespaces assocs words.symbol ;
+IN: bootstrap.image.syntax
+
+SYMBOL: userenvs
+
+SYNTAX: RESET H{ } clone userenvs set-global ;
+
+SYNTAX: USERENV:
+    CREATE-WORD scan-word
+    [ swap userenvs get set-at ]
+    [ drop define-symbol ]
+    2bi ;

basis/bootstrap/stage2.factor

@@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time
 
 SYMBOL: bootstrap-time
 
+: strip-encodings ( -- )
+    os unix? [
+        [
+            P" resource:core/io/encodings/utf16/utf16.factor" 
+            P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@
+            "io.encodings.utf16" 
+            "io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@
+        ] with-compilation-unit
+    ] when ;
+
 : default-image-name ( -- string )
     vm file-name os windows? [ "." split1-last drop ] when
     ".image" append resource-path ;
@@ -55,6 +65,8 @@ SYMBOL: bootstrap-time
     "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
     "" "exclude" set-global
 
+    strip-encodings
+
     (command-line) parse-command-line
 
     ! Set dll paths

basis/checksums/common/common.factor

@@ -9,6 +9,9 @@ SYMBOL: bytes-read
 : calculate-pad-length ( length -- length' )
     [ 56 < 55 119 ? ] keep - ;
 
+: calculate-pad-length-long ( length -- length' )
+    [ 120 < 119 247 ? ] keep - ;
+
 : pad-last-block ( str big-endian? length -- str )
     [
         [ % ] 2dip HEX: 80 ,

basis/checksums/sha2/sha2-tests.factor

@@ -1,7 +1,42 @@
-USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
+USING: arrays kernel math namespaces sequences tools.test
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
+checksums.sha2 checksums ;
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
+IN: checksums.sha2.tests
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
+
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
+: test-checksum ( text identifier -- checksum )
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
+    checksum-bytes hex-string ;
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
+
+[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
+[
+    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+    sha-224 test-checksum
+] unit-test
+
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
+[ "" sha-256 test-checksum ] unit-test
+
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
+[ "abc" sha-256 test-checksum ] unit-test
+
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
+[ "message digest" sha-256 test-checksum ] unit-test
+
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
+[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
+
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
+[
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+    sha-256 test-checksum
+] unit-test
+
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
+[
+    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+    sha-256 test-checksum
+] unit-test
+
+
+
+
+! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
+! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test

basis/checksums/sha2/sha2.factor

@@ -2,12 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings ;
+sbufs strings combinators.smart math.ranges fry combinators
+accessors locals ;
 IN: checksums.sha2
 
-<PRIVATE
+SINGLETON: sha-224
+SINGLETON: sha-256
 
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
+
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+<PRIVATE
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -18,13 +33,43 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
-: initial-H-256 ( -- seq )
+CONSTANT: initial-H-224
+    {
+        HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+        HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+    }
+
+CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
-    } ;
+    }
 
-: K-256 ( -- seq )
+CONSTANT: initial-H-384
+    {
+        HEX: cbbb9d5dc1059ed8
+        HEX: 629a292a367cd507
+        HEX: 9159015a3070dd17
+        HEX: 152fecd8f70e5939
+        HEX: 67332667ffc00b31
+        HEX: 8eb44a8768581511
+        HEX: db0c2e0d64f98fa7
+        HEX: 47b5481dbefa4fa4
+    }
+
+CONSTANT: initial-H-512
+    {
+        HEX: 6a09e667f3bcc908
+        HEX: bb67ae8584caa73b
+        HEX: 3c6ef372fe94f82b
+        HEX: a54ff53a5f1d36f1
+        HEX: 510e527fade682d1
+        HEX: 9b05688c2b3e6c1f
+        HEX: 1f83d9abfb41bd6b
+        HEX: 5be0cd19137e2179
+    }
+
+CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
@@ -42,62 +87,163 @@ CONSTANT: h 7
         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
-    } ;
+    }
+
+CONSTANT: K-384
+    {
+
+        HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc 
+        HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 
+        HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
+        HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
+        HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
+        HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
+        HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 
+        HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 
+        HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df 
+        HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b 
+        HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 
+        HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 
+        HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 
+        HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 
+        HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec 
+        HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b 
+        HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 
+        HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b 
+        HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c 
+        HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+    }
+
+ALIAS: K-512 K-384
 
 : s0-256 ( x -- x' )
-    [ -7 bitroll-32 ] keep
+    [
-    [ -18 bitroll-32 ] keep
+        [ -7 bitroll-32 ]
-    -3 shift bitxor bitxor ; inline
+        [ -18 bitroll-32 ]
+        [ -3 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : s1-256 ( x -- x' )
-    [ -17 bitroll-32 ] keep
+    [
-    [ -19 bitroll-32 ] keep
+        [ -17 bitroll-32 ]
-    -10 shift bitxor bitxor ; inline
+        [ -19 bitroll-32 ]
-
+        [ -10 shift ] tri
-: process-M-256 ( seq n -- )
+    ] [ bitxor ] reduce-outputs ; inline
-    [ 16 - swap nth ] 2keep
-    [ 15 - swap nth s0-256 ] 2keep
-    [ 7 - swap nth ] 2keep
-    [ 2 - swap nth s1-256 ] 2keep
-    [ + + w+ ] 2dip swap set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
-    word-size get group [ be> ] map block-size get 0 pad-tail
-    dup 16 64 dup <slice> [
-        process-M-256
-    ] with each ;
-
-: ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
-    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
-    [ -2 bitroll-32 ] keep
+    [
-    [ -13 bitroll-32 ] keep
+        [ -2 bitroll-32 ]
-    -22 bitroll-32 bitxor bitxor ; inline
+        [ -13 bitroll-32 ]
+        [ -22 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : S1-256 ( x -- x' )
-    [ -6 bitroll-32 ] keep
+    [
-    [ -11 bitroll-32 ] keep
+        [ -6 bitroll-32 ]
-    -25 bitroll-32 bitxor bitxor ; inline
+        [ -11 bitroll-32 ]
+        [ -25 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+: s0-512 ( x -- x' )
+    [
+        [ -1 bitroll-64 ]
+        [ -8 bitroll-64 ]
+        [ -7 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T1 ( W n -- T1 )
+: s1-512 ( x -- x' )
-    [ swap nth ] keep
+    [
-    K get nth +
+        [ -19 bitroll-64 ]
-    e vars get slice3 ch +
+        [ -61 bitroll-64 ]
-    e vars get nth S1-256 +
+        [ -6 shift ] tri
-    h vars get nth w+ ;
+    ] [ bitxor ] reduce-outputs ; inline
 
-: T2 ( -- T2 )
+: S0-512 ( x -- x' )
-    a vars get nth S0-256
+    [
-    a vars get slice3 maj w+ ;
+        [ -28 bitroll-64 ]
+        [ -34 bitroll-64 ]
+        [ -39 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
-: update-vars ( T1 T2 -- )
+: S1-512 ( x -- x' )
-    vars get
+    [
+        [ -14 bitroll-64 ]
+        [ -18 bitroll-64 ]
+        [ -41 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: process-M-512 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
+: ch ( x y z -- x' )
+    [ bitxor bitand ] keep bitxor ; inline
+
+: maj ( x y z -- x' )
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
+
+: slice3 ( n seq -- a b c )
+    [ dup 3 + ] dip <slice> first3 ; inline
+
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
+
+M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
+    drop
+    dup [
+        HEX: 80 ,
+        length
+        [ 64 mod calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
+    drop dup [
+        HEX: 80 ,
+        length
+        [ 128 mod calculate-pad-length-long 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
+
+:: T1-256 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-256 w+
+    h H nth w+ ; inline
+
+: T2-256 ( H -- T2 )
+    [ a swap nth S0-256 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+:: T1-512 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-512 w+
+    h H nth w+ ; inline
+
+: T2-512 ( H -- T2 )
+    [ a swap nth S0-512 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
+: update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
     f e pick exchange
@@ -105,42 +251,56 @@ CONSTANT: h 7
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    [ w+ a ] dip set-nth ;
+    [ w+ a ] dip set-nth ; inline
 
-: process-chunk ( M -- )
+: prepare-message-schedule ( seq sha2 -- w-seq )
-    H get clone vars set
+    [ word-size>> <sliced-groups> [ be> ] map ]
-    prepare-message-schedule block-size get [
+    [
-        T1 T2 update-vars
+        block-size>> [ 0 pad-tail 16 ] keep [a,b) over
-    ] with each vars get H get [ w+ ] 2map H set ;
+        '[ _ process-M-256 ] each
+    ] bi ; inline
 
-: seq>byte-array ( n seq -- string )
+:: process-chunk ( M block-size cloned-H sha2 -- )
-    [ swap [ >be % ] curry each ] B{ } make ;
+    block-size [
+        M cloned-H sha2 T1-256
+        cloned-H T2-256
+        cloned-H update-H
+    ] each
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
 
-: preprocess-plaintext ( string big-endian? -- padded-string )
+: sha2-steps ( sliced-groups state -- )
-    #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
+    '[
-    [ >sbuf ] dip over [
+        _
-        HEX: 80 ,
+        [ prepare-message-schedule ]
-        dup length HEX: 3f bitand
+        [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
-        calculate-pad-length 0 <string> %
+    ] each ;
-        length 3 shift 8 rot [ >be ] [ >le ] if %
-    ] "" make over push-all ;
 
-: byte-array>sha2 ( byte-array -- string )
+: byte-array>sha2 ( bytes state -- )
-    t preprocess-plaintext
+    [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
-    block-size get group [ process-chunk ] each
+    [ sha2-steps ] bi ;
-    4 H get seq>byte-array ;
+
+: <sha-224-state> ( -- sha2-state )
+    sha-224-state new
+        K-256 >>K
+        initial-H-224 >>H
+        4 >>word-size
+        64 >>block-size ;
+
+: <sha-256-state> ( -- sha2-state )
+    sha-256-state new
+        K-256 >>K
+        initial-H-256 >>H
+        4 >>word-size
+        64 >>block-size ;
 
 PRIVATE>
 
-SINGLETON: sha-256
+M: sha-224 checksum-bytes
-
+    drop <sha-224-state>
-INSTANCE: sha-256 checksum
+    [ byte-array>sha2 ]
+    [ H>> 7 head 4 seq>byte-array ] bi ;
 
 M: sha-256 checksum-bytes
-    drop [
+    drop <sha-256-state>
-        K-256 K set
+    [ byte-array>sha2 ]
-        initial-H-256 H set
+    [ H>> 4 seq>byte-array ] bi ;
-        4 word-size set
-        64 block-size set
-        byte-array>sha2
-    ] with-scope ;

basis/circular/circular-docs.factor

@@ -43,6 +43,11 @@ HELP: push-growing-circular
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element onto a " { $link growing-circular } " object." } ;
 
+HELP: rotate-circular
+{ $values
+    { "circular" circular } }
+{ $description "Advances the start index of a circular object by one." } ;
+
 ARTICLE: "circular" "Circular sequences"
 "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
 "Creating a new circular object:"
@@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences"
 { $subsection <growing-circular> }
 "Changing the start index:"
 { $subsection change-circular-start }
+{ $subsection rotate-circular }
 "Pushing new elements:"
 { $subsection push-circular }
 { $subsection push-growing-circular } ;

basis/circular/circular-tests.factor

@@ -12,6 +12,7 @@ circular strings ;
 [ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
  
 [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
+[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
 [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test

basis/circular/circular.factor

@@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ;
     #! change start to (start + n) mod length
     circular-wrap (>>start) ;
 
+: rotate-circular ( circular -- )
+    [ start>> 1 + ] keep circular-wrap (>>start) ;
+
 : push-circular ( elt circular -- )
     [ set-first ] [ 1 swap change-circular-start ] bi ;
 

basis/cocoa/application/application.factor

@@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
 NSApplicationDelegateReplyFailure ;
 
 : with-autorelease-pool ( quot -- )
-    NSAutoreleasePool -> new slip -> release ; inline
+    NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 

basis/cocoa/cocoa.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler io kernel cocoa.runtime cocoa.subclassing
 cocoa.messages cocoa.types sequences words vocabs parser
@@ -27,22 +27,16 @@ SYMBOL: frameworks
 
 frameworks [ V{ } clone ] initialize
 
-[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
 
 SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
 
 SYNTAX: IMPORT: scan [ ] import-objc-class ;
 
-"Compiling Objective C bridge..." print
+"Importing Cocoa classes..." print
 
 "cocoa.classes" create-vocab drop
 
-{
-    "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
-} [ words ] map concat compile
-
-"Importing Cocoa classes..." print
-
 [
     {
         "NSApplication"

basis/cocoa/messages/messages.factor

@@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
     [ dup lookup-method ] dip
     [ make-prepare-send ] 2keep
     super-message-senders message-senders ? get at
-    '[ _ call _ execute ] ;
+    1quotation append ;
 
 : send ( receiver args... selector -- return... ) f (send) ; inline
 

basis/cocoa/plists/plists.factor

@@ -4,7 +4,7 @@
 USING: strings arrays hashtables assocs sequences fry macros
 cocoa.messages cocoa.classes cocoa.application cocoa kernel
 namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types words core-foundation
+combinators alien.c-types words core-foundation quotations
 core-foundation.data core-foundation.utilities ;
 IN: cocoa.plists
 
@@ -41,10 +41,16 @@ DEFER: plist>
     *void* [ -> release "read-plist failed" throw ] when* ;
 
 MACRO: objc-class-case ( alist -- quot )
-    [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
+    [
+        dup callable?
+        [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
+        unless
+    ] map '[ _ cond ] ;
 
 PRIVATE>
 
+ERROR: invalid-plist-object object ;
+
 : plist> ( plist -- value )
     {
         { NSString [ (plist-NSString>) ] }
@@ -53,6 +59,7 @@ PRIVATE>
         { NSArray [ (plist-NSArray>) ] }
         { NSDictionary [ (plist-NSDictionary>) ] }
         { NSObject [ ] }
+        [ invalid-plist-object ]
     } objc-class-case ;
 
 : read-plist ( path -- assoc )

basis/combinators/smart/smart.factor

@@ -11,8 +11,8 @@ MACRO: output>sequence ( quot exemplar -- newquot )
     [ dup infer out>> ] dip
     '[ @ _ _ nsequence ] ;
 
-: output>array ( quot -- newquot )
+MACRO: output>array ( quot -- newquot )
-    { } output>sequence ; inline
+    '[ _ { } output>sequence ] ;
 
 MACRO: input<sequence ( quot -- newquot )
     [ infer in>> ] keep
@@ -25,8 +25,8 @@ MACRO: input<sequence-unsafe ( quot -- newquot )
 MACRO: reduce-outputs ( quot operation -- newquot )
     [ dup infer out>> 1 [-] ] dip n*quot compose ;
 
-: sum-outputs ( quot -- n )
+MACRO: sum-outputs ( quot -- n )
-    [ + ] reduce-outputs ; inline
+    '[ _ [ + ] reduce-outputs ] ;
 
 MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
     [ dup infer out>> ] 2dip
@@ -37,5 +37,5 @@ MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
 MACRO: append-outputs-as ( quot exemplar -- newquot )
     [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
 
-: append-outputs ( quot -- seq )
+MACRO: append-outputs ( quot -- seq )
-    { } append-outputs-as ; inline
+    '[ _ { } append-outputs-as ] ;

basis/compiler/codegen/codegen.factor

@@ -88,7 +88,7 @@ M: ##call generate-insn
     word>> dup sub-primitive>>
     [ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
 
-M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 
@@ -444,8 +444,7 @@ TUPLE: callback-context ;
 
 : do-callback ( quot token -- )
     init-catchstack
-    dup 2 setenv
+    [ 2 setenv call ] keep
-    slip
     wait-to-return ; inline
 
 : callback-return-quot ( ctype -- quot )

basis/compiler/codegen/fixup/fixup.factor

@@ -56,8 +56,11 @@ SYMBOL: literal-table
 : rel-word ( word class -- )
     [ add-literal ] dip rt-xt rel-fixup ;
 
-: rel-word-direct ( word class -- )
+: rel-word-pic ( word class -- )
-    [ add-literal ] dip rt-xt-direct rel-fixup ;
+    [ add-literal ] dip rt-xt-pic rel-fixup ;
+
+: rel-word-pic-tail ( word class -- )
+    [ add-literal ] dip rt-xt-pic-tail rel-fixup ;
 
 : rel-primitive ( word class -- )
     [ def>> first add-literal ] dip rt-primitive rel-fixup ;

basis/compiler/compiler.factor

@@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
     } cond ;
 
 : optimize? ( word -- ? )
-    {
+    { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
-        [ predicate-engine-word? ]
+
-        [ contains-breakpoints? ]
+: contains-breakpoints? ( -- ? )
-        [ single-generic? ]
+    dependencies get keys [ "break?" word-prop ] any? ;
-    } 1|| not ;
 
 : frontend ( word -- nodes )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
-    dup optimize?
+    dup optimize? [
-    [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
+        [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
-    [ dup def>> deoptimize-with ]
+        contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
-    if ;
+    ] [ dup def>> deoptimize-with ] if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.

basis/compiler/constants/constants.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel layouts system strings words quotations byte-arrays
-alien arrays ;
+alien arrays literals sequences ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
@@ -14,42 +14,42 @@ CONSTANT: deck-bits 18
 : float-offset ( -- n ) 8 float tag-number - ; inline
 : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
 : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
+: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
 : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
 : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
 : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
+: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
+: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
+: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
 : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
-: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
 
 ! Relocation classes
-CONSTANT: rc-absolute-cell    0
+CONSTANT: rc-absolute-cell 0
-CONSTANT: rc-absolute         1
+CONSTANT: rc-absolute 1
-CONSTANT: rc-relative         2
+CONSTANT: rc-relative 2
 CONSTANT: rc-absolute-ppc-2/2 3
-CONSTANT: rc-relative-ppc-2   4
+CONSTANT: rc-absolute-ppc-2 4
-CONSTANT: rc-relative-ppc-3   5
+CONSTANT: rc-relative-ppc-2 5
-CONSTANT: rc-relative-arm-3   6
+CONSTANT: rc-relative-ppc-3 6
-CONSTANT: rc-indirect-arm     7
+CONSTANT: rc-relative-arm-3 7
-CONSTANT: rc-indirect-arm-pc  8
+CONSTANT: rc-indirect-arm 8
+CONSTANT: rc-indirect-arm-pc 9
 
 ! Relocation types
-CONSTANT: rt-primitive   0
+CONSTANT: rt-primitive 0
-CONSTANT: rt-dlsym       1
+CONSTANT: rt-dlsym 1
-CONSTANT: rt-dispatch    2
+CONSTANT: rt-dispatch 2
-CONSTANT: rt-xt          3
+CONSTANT: rt-xt 3
-CONSTANT: rt-xt-direct   4
+CONSTANT: rt-xt-pic 4
-CONSTANT: rt-here        5
+CONSTANT: rt-xt-pic-tail 5
-CONSTANT: rt-this        6
+CONSTANT: rt-here 6
-CONSTANT: rt-immediate   7
+CONSTANT: rt-this 7
-CONSTANT: rt-stack-chain 8
+CONSTANT: rt-immediate 8
-CONSTANT: rt-untagged    9
+CONSTANT: rt-stack-chain 9
+CONSTANT: rt-untagged 10
+CONSTANT: rt-megamorphic-cache-hits 11
 
 : rc-absolute? ( n -- ? )
-    [ rc-absolute-ppc-2/2 = ]
+    ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
-    [ rc-absolute-cell = ]
-    [ rc-absolute = ]
-    tri or or ;

basis/compiler/tests/alien.factor

@@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
     C{ 1.0 2.0 }
     C{ 1.5 1.0 } ffi_test_47
 ] unit-test
+
+! Reported by jedahu
+C-STRUCT: bool-field-test
+   { "char*" "name" }
+   { "bool"  "on" }
+   { "short" "parents" } ;
+
+FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
+
+[ 123 ] [
+    "bool-field-test" <c-object> 123 over set-bool-field-test-parents
+    ffi_test_48
+] unit-test

basis/compiler/tests/curry.factor

@@ -33,7 +33,7 @@ IN: compiler.tests.curry
 ] unit-test
 
 : foobar ( quot: ( -- ) -- )
-    dup slip swap [ foobar ] [ drop ] if ; inline recursive
+    [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
 
 [ ] [ [ [ f ] foobar ] compile-call ] unit-test
 

basis/compiler/tests/optimizer.factor

@@ -389,4 +389,26 @@ DEFER: loop-bbb
 
 [ f ] [ \ broken-declaration optimized? ] unit-test
 
-[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+
+! Modular arithmetic bug
+: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
+
+[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
+[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
+
+! Optimizer needs to ignore invalid generics
+GENERIC# bad-dispatch-position-test* 3 ( -- )
+
+M: object bad-dispatch-position-test* ;
+
+: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
+
+[ 1 2 3 4 bad-dispatch-position-test ] must-fail
+
+[ ] [
+    [
+        \ bad-dispatch-position-test forget
+        \ bad-dispatch-position-test* forget
+    ] with-compilation-unit
+] unit-test

basis/compiler/tree/builder/builder.factor

@@ -65,5 +65,3 @@ PRIVATE>
         ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
     ] with-variable ;
 
-: contains-breakpoints? ( word -- ? )
-    def>> [ word? ] filter [ "break?" word-prop ] any? ;

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -302,7 +302,7 @@ C: <ro-box> ro-box
 [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
 
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
     ] { mod fixnum-mod } inlined?
 ] unit-test
 
-
 [ f ] [
     [
         256 mod
     ] { mod fixnum-mod } inlined?
 ] unit-test
 
+[ f ] [
+    [
+        >fixnum 256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
 [ f ] [
     [
         dup 0 >= [ 256 mod ] when
@@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
         { integer } declare [ 256 rem ] map
     ] { mod fixnum-mod rem } inlined?
 ] unit-test
+
+[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.partial-dispatch namespaces sequences sets
 accessors assocs words kernel memoize fry combinators
+combinators.short-circuit
 compiler.tree
 compiler.tree.combinators
 compiler.tree.def-use
@@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
 : optimize->fixnum ( #call -- nodes )
     dup redundant->fixnum? [ drop f ] when ;
 
+: optimize->integer ( #call -- nodes )
+    dup out-d>> first actually-used-by dup length 1 = [
+        first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
+        [ drop { } ] when
+    ] [ drop ] if ;
+
 MEMO: fixnum-coercion ( flags -- nodes )
     [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
 
@@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
 M: #call optimize-modular-arithmetic*
     dup word>> {
         { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+        { [ dup \ >integer eq? ] [ drop optimize->integer ] }
         { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
         [ drop ]
     } cond ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -59,9 +59,11 @@ M: callable splicing-nodes splicing-body ;
 
 : inlining-standard-method ( #call word -- class/f method/f )
     dup "methods" word-prop assoc-empty? [ 2drop f f ] [
-        [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
+        2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
-        [ swap nth value-info class>> dup ] dip
+            [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
-        specific-method
+            [ swap nth value-info class>> dup ] dip
+            specific-method
+        ] if
     ] if ;
 
 : inline-standard-method ( #call word -- ? )
@@ -157,11 +159,7 @@ DEFER: (flat-length)
     ] sum-outputs ;
 
 : should-inline? ( #call word -- ? )
-    {
+    dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
-        { [ dup contains-breakpoints? ] [ 2drop f ] }
-        { [ dup "inline" word-prop ] [ 2drop t ] }
-        [ inlining-rank 5 >= ]
-    } cond ;
 
 SYMBOL: history
 

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
 comparison-ops
 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
 
-! generic-comparison-ops [
-!     dup specific-comparison define-comparison-constraints
-! ] each
-
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )
     [ [ interval>> ] bi@ ] dip interval-comparison {
@@ -217,6 +213,8 @@ generic-comparison-ops [
     { >float float }
     { fixnum>float float }
     { bignum>float float }
+
+    { >integer integer }
 } [
     '[
         _
@@ -228,19 +226,26 @@ generic-comparison-ops [
     ] "outputs" set-word-prop
 ] assoc-each
 
+: rem-custom-inlining ( #call -- quot/f )
+    second value-info literal>> dup integer?
+    [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+
 {
     mod-integer-integer
     mod-integer-fixnum
     mod-fixnum-integer
     fixnum-mod
-    rem
 } [
     [
-        in-d>> second value-info >literal<
+        in-d>> dup first value-info interval>> [0,inf] interval-subset?
-        [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
+        [ rem-custom-inlining ] [ drop f ] if
     ] "custom-inlining" set-word-prop
 ] each
 
+\ rem [
+    in-d>> rem-custom-inlining
+] "custom-inlining" set-word-prop
+
 {
     bitand-integer-integer
     bitand-integer-fixnum

basis/compiler/tree/propagation/propagation-tests.factor

@@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 ! Mutable tuples with circularity should not cause problems
 TUPLE: circle me ;
 
-[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+
+! Joe found an oversight
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -39,7 +39,7 @@ TUPLE: empty-tuple ;
 
 ! A more complicated example
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive

basis/core-graphics/core-graphics.factor

@@ -105,6 +105,19 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
 
 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
 
+FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
+
+FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
+FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
+
+FUNCTION: CGError CGDisplayMoveCursorToPoint ( CGDirectDisplayID display, CGPoint point ) ;
+
+FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
+
+FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
+
+FUNCTION: uint GetCurrentButtonState ( ) ;
+
 <PRIVATE
 
 : bitmap-flags ( -- flags )

basis/core-graphics/types/types.factor

@@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
 TYPEDEF: uint CGBitmapInfo
 
 TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
 TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
+TYPEDEF: int CGLContextParameter

basis/cpu/architecture/architecture.factor

@@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
 
 HOOK: stack-frame-size cpu ( stack-frame -- n )
 HOOK: %call cpu ( word -- )
+HOOK: %jump cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 

basis/cpu/ppc/assembler/assembler-tests.factor

@@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
 make vocabs sequences ;
 
 : test-assembler ( expected quot -- )
-    [ 1array ] [ [ { } make ] curry ] bi* unit-test ;
+    [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
 
-{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
+B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
-{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
+B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
-{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
+B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
-{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
+B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
-{ HEX: 38400001 } [ 1 2 LI ] test-assembler
+B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
-{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
+B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
-{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
+B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
-{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
+B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
-{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
-{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
-{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
-{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
-{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
-{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
-{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
-{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
-{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
-{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
-{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
-{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
-{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
-{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
-{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
-{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
+B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
-{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
+B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
-{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
-{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
-{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
-{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
+B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
-{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
-{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
-{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
-{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
-{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
-{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
-{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
-{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
-{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
-{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
-{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
+B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
-{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
-{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
-{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
+B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
-{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
+B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
-{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
-{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
-{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
-{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
-{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
+B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
-{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
+B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
-{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
+B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
-{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
+B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
-{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
+B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
-{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
+B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
-{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
+B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
-{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
+B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
-{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
-{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
-{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
-{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
-{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
-{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
-{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
-{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
-{ HEX: 48000001 } [ 1 B ] test-assembler
+B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
-{ HEX: 48000001 } [ 1 BL ] test-assembler
+B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
-{ HEX: 41800004 } [ 1 BLT ] test-assembler
+B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-{ HEX: 41810004 } [ 1 BGT ] test-assembler
+B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
-{ HEX: 40810004 } [ 1 BLE ] test-assembler
+B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
-{ HEX: 40800004 } [ 1 BGE ] test-assembler
+B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
-{ HEX: 41800004 } [ 1 BLT ] test-assembler
+B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-{ HEX: 40820004 } [ 1 BNE ] test-assembler
+B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
-{ HEX: 41820004 } [ 1 BEQ ] test-assembler
+B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
-{ HEX: 41830004 } [ 1 BO ] test-assembler
+B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
-{ HEX: 40830004 } [ 1 BNO ] test-assembler
+B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
-{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
+B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
-{ HEX: 4e800020 } [ BLR ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
-{ HEX: 4e800021 } [ BLRL ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
-{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
+B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
-{ HEX: 4e800420 } [ BCTR ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
-{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
+B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
-{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
-{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
-{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
+B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
-{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
+B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
-{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
+B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
-{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
+B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
-{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
+B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
-{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
+B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
-{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
+B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
-{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
+B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
-{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
+B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
-{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
-{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
-{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
-{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
-{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
-{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
-{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
-{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
-{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
+B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
-{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
+B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
-{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
+B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler

basis/cpu/ppc/assembler/assembler.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup kernel namespaces words
+USING: kernel namespaces words io.binary math math.order
-io.binary math math.order cpu.ppc.assembler.backend ;
+cpu.ppc.assembler.backend ;
 IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode

basis/cpu/ppc/assembler/backend/backend.factor

@@ -1,11 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup cpu.architecture
+USING:  kernel namespaces make sequences words math
-compiler.constants kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer fry ;
-math.bitwise io.binary parser lexer ;
 IN: cpu.ppc.assembler.backend
 
-: insn ( operand opcode -- ) { 26 0 } bitfield , ;
+: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
 
 : a-insn ( d a b c xo rc opcode -- )
     [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
@@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
 
 GENERIC# (B) 2 ( dest aa lk -- )
 M: integer (B) 18 i-insn ;
-M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
-M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
 
 GENERIC: BC ( a b c -- )
 M: integer BC 0 0 16 b-insn ;
-M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
-M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 : CREATE-B ( -- word ) scan "B" prepend create-in ;
 
 SYNTAX: BC:
     CREATE-B scan-word scan-word
-    [ rot BC ] 2curry (( c -- )) define-declared ;
+    '[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
 
 SYNTAX: B:
     CREATE-B scan-word scan-word scan-word scan-word scan-word
-    [ b-insn ] curry curry curry curry curry
+    '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
-    (( bo -- )) define-declared ;

basis/cpu/ppc/bootstrap.factor

@@ -9,8 +9,8 @@ IN: bootstrap.ppc
 4 \ cell set
 big-endian on
 
-CONSTANT: ds-reg 29
+CONSTANT: ds-reg 13
-CONSTANT: rs-reg 30
+CONSTANT: rs-reg 14
 
 : factor-area-size ( -- n ) 4 bootstrap-cells ;
 
@@ -21,46 +21,48 @@ CONSTANT: rs-reg 30
 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
 
 [
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    11 6 profile-count-offset LWZ
+    11 3 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
-    11 6 profile-count-offset STW
+    11 3 profile-count-offset STW
-    11 6 word-code-offset LWZ
+    11 3 word-code-offset LWZ
     11 11 compiled-header-size ADDI
     11 MTCTR
     BCTR
 ] jit-profiling jit-define
 
 [
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
     0 MFLR
     1 1 stack-frame SUBI
-    6 1 xt-save STW
+    3 1 xt-save STW
-    stack-frame 6 LI
+    stack-frame 3 LI
-    6 1 next-save STW
+    3 1 next-save STW
     0 1 lr-save stack-frame + STW
 ] jit-prolog jit-define
 
 [
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    6 ds-reg 4 STWU
+    3 ds-reg 4 STWU
 ] jit-push-immediate jit-define
 
 [
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
-    7 6 0 LWZ
+    4 3 0 LWZ
-    1 7 0 STW
+    1 4 0 STW
-] jit-save-stack jit-define
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
-
+    3 MTCTR
-[
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
-    6 MTCTR
     BCTR
 ] jit-primitive jit-define
 
-[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
+[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
 
-[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
+[
+    0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
+    0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
+] jit-word-jump jit-define
+
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
 
 [
     3 ds-reg 0 LWZ
@@ -68,11 +70,8 @@ CONSTANT: rs-reg 30
     0 3 \ f tag-number CMPI
     2 BEQ
     0 B rc-relative-ppc-3 rt-xt jit-rel
-] jit-if-1 jit-define
-
-[
     0 B rc-relative-ppc-3 rt-xt jit-rel
-] jit-if-2 jit-define
+] jit-if jit-define
 
 : jit->r ( -- )
     4 ds-reg 0 LWZ
@@ -138,6 +137,16 @@ CONSTANT: rs-reg 30
     jit-3r>
 ] jit-3dip jit-define
 
+: prepare-(execute) ( -- operand )
+    3 ds-reg 0 LWZ
+    ds-reg dup 4 SUBI
+    4 3 word-xt-offset LWZ
+    4 ;
+
+[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
+
+[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
+
 [
     0 1 lr-save stack-frame + LWZ
     1 1 stack-frame ADDI
@@ -146,7 +155,99 @@ CONSTANT: rs-reg 30
 
 [ BLR ] jit-return jit-define
 
-! Sub-primitives
+! ! ! Polymorphic inline caches
+
+! Don't touch r6 here; it's used to pass the tail call site
+! address for tail PICs
+
+! Load a value from a stack position
+[
+    4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
+] pic-load jit-define
+
+! Tag
+: load-tag ( -- )
+    4 4 tag-mask get ANDI
+    4 4 tag-bits get SLWI ;
+
+[ load-tag ] pic-tag jit-define
+
+! Hi-tag
+[
+    3 4 MR
+    load-tag
+    0 4 object tag-number tag-fixnum CMPI
+    2 BNE
+    4 3 object tag-number neg LWZ
+] pic-hi-tag jit-define
+
+! Tuple
+[
+    3 4 MR
+    load-tag
+    0 4 tuple tag-number tag-fixnum CMPI
+    2 BNE
+    4 3 tuple tag-number neg bootstrap-cell + LWZ
+] pic-tuple jit-define
+
+! Hi-tag and tuple
+[
+    3 4 MR
+    load-tag
+    ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
+    0 4 BIN: 110 tag-fixnum CMPI
+    5 BLT
+    ! Untag r3
+    3 3 0 0 31 tag-bits get - RLWINM
+    ! Set r4 to 0 for objects, and bootstrap-cell for tuples
+    4 4 1 tag-fixnum ANDI
+    4 4 1 SRAWI
+    ! Load header cell or tuple layout cell
+    4 4 3 LWZX
+] pic-hi-tag-tuple jit-define
+
+[
+    0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
+] pic-check-tag jit-define
+
+[
+    0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    4 0 5 CMP
+] pic-check jit-define
+
+[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
+
+! ! ! Megamorphic caches
+
+[
+    ! cache = ...
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
+    ! key = class
+    5 4 MR
+    ! key &= cache.length - 1
+    5 5 mega-cache-size get 1- bootstrap-cell * ANDI
+    ! cache += array-start-offset
+    3 3 array-start-offset ADDI
+    ! cache += key
+    3 3 5 ADD
+    ! if(get(cache) == class)
+    6 3 0 LWZ
+    6 0 4 CMP
+    10 BNE
+    ! megamorphic_cache_hits++
+    0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
+    5 4 0 LWZ
+    5 5 1 ADDI
+    5 4 0 STW
+    ! ... goto get(cache + bootstrap-cell)
+    3 3 4 LWZ
+    3 3 word-xt-offset LWZ
+    3 MTCTR
+    BCTR
+    ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
 
 ! Quotations and words
 [
@@ -157,14 +258,6 @@ CONSTANT: rs-reg 30
     BCTR
 ] \ (call) define-sub-primitive
 
-[
-    3 ds-reg 0 LWZ
-    ds-reg dup 4 SUBI
-    4 3 word-xt-offset LWZ
-    4 MTCTR
-    BCTR
-] \ (execute) define-sub-primitive
-
 ! Objects
 [
     3 ds-reg 0 LWZ

basis/cpu/ppc/ppc.factor

@@ -1,33 +1,39 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
-alien alien.c-types cpu.architecture cpu.ppc.assembler
+alien alien.accessors alien.c-types literals cpu.architecture
-compiler.cfg.registers compiler.cfg.instructions
+cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
-compiler.constants compiler.codegen compiler.codegen.fixup
+compiler.cfg.instructions compiler.constants compiler.codegen
-compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+compiler.codegen.fixup compiler.cfg.intrinsics
+compiler.cfg.stack-frame compiler.units ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
-! r2-r27: integer vregs
+! r2-r12: integer vregs
-! r28: integer scratch
+! r15-r29
-! r29: data stack
+! r30: integer scratch
-! r30: retain stack
 ! f0-f29: float vregs
-! f30, f31: float scratch
+! f30: float scratch
+
+! Add some methods to the assembler that are useful to us
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 enable-float-intrinsics
 
-<< \ ##integer>float t frame-required? set-word-prop
+<<
-\ ##float>integer t frame-required? set-word-prop >>
+\ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop
+>>
 
 M: ppc machine-registers
     {
-        { int-regs T{ range f 2 26 1 } }
+        { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
-        { double-float-regs T{ range f 0 29 1 } }
+        { double-float-regs $[ 0 29 [a,b] ] }
     } ;
 
-CONSTANT: scratch-reg 28
+CONSTANT: scratch-reg 30
 CONSTANT: fp-scratch-reg 30
 
 M: ppc two-operand? f ;
@@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- )
 M: ppc %alien-global ( register symbol dll -- )
     [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
 
-CONSTANT: ds-reg 29
+CONSTANT: ds-reg 13
-CONSTANT: rs-reg 30
+CONSTANT: rs-reg 14
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
     factor-area-size +
     4 cells align ;
 
-M: ppc %call ( label -- ) BL ;
+M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
+
+M: ppc %jump ( word -- )
+    0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
+    0 B rc-relative-ppc-3 rel-word-pic-tail ;
+
 M: ppc %jump-label ( label -- ) B ;
 M: ppc %return ( -- ) BLR ;
 
@@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
     BCTR ;
 
 M: ppc %dispatch-label ( word -- )
-    0 , rc-absolute-cell rel-word ;
+    B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
 
 :: (%slot) ( obj slot tag temp -- reg offset )
     temp slot obj ADD
@@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
 
 M: ppc %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
-    13 3 MR ;
+    15 3 MR ;
 
 M: ppc %alien-indirect ( -- )
-    13 MTLR BLRL ;
+    15 MTLR BLRL ;
 
 M: ppc %callback-value ( ctype -- )
     ! Save top of data stack
@@ -702,3 +713,14 @@ USE: vocabs.loader
 } cond
 
 "complex-double" c-type t >>return-in-registers? drop
+
+[
+    <c-type>
+        [ alien-unsigned-4 c-bool> ] >>getter
+        [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+        4 >>size
+        4 >>align
+        "box_boolean" >>boxer
+        "to_boolean" >>unboxer
+    "bool" define-primitive-type
+] with-compilation-unit

basis/cpu/x86/32/32.factor

@@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
 M: x86.32 param-reg-1 EAX ;
 M: x86.32 param-reg-2 EDX ;
 
+M: x86.32 pic-tail-reg EBX ;
+
 M: x86.32 reserved-area-size 0 ;
 
-M: x86.32 %alien-invoke (CALL) rel-dlsym ;
+M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
 
-M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
+M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
 
 M: x86.32 return-struct-in-registers? ( c-type -- ? )
     c-type

basis/cpu/x86/32/bootstrap.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
 cpu.x86.assembler layouts vocabs parser compiler.constants ;
@@ -26,10 +26,8 @@ IN: bootstrap.x86
     temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
     ! save stack pointer
     temp0 [] stack-reg MOV
-] jit-save-stack jit-define
+    ! call the primitive
-
+    0 JMP rc-relative rt-primitive jit-rel
-[
-    (JMP) drop rc-relative rt-primitive jit-rel
 ] jit-primitive jit-define
 
 << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>

basis/cpu/x86/64/64.factor

@@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
 M: x86.64 param-reg-2 int-regs param-regs second ;
 : param-reg-3 ( -- reg ) int-regs param-regs third ; inline
 
+M: x86.64 pic-tail-reg RBX ;
+
 M: int-regs return-reg drop RAX ;
 M: float-regs return-reg drop XMM0 ;
 

basis/cpu/x86/64/bootstrap.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
 cpu.x86.assembler layouts vocabs parser compiler.constants math ;
@@ -25,9 +25,6 @@ IN: bootstrap.x86
     temp0 temp0 [] MOV
     ! save stack pointer
     temp0 [] stack-reg MOV
-] jit-save-stack jit-define
-
-[
     ! load XT
     temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
     ! go

basis/cpu/x86/assembler/assembler.factor

@@ -1,12 +1,11 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays cpu.architecture compiler.constants
+USING: arrays io.binary kernel combinators
-compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system layouts
-kernel.private math namespaces make sequences words system
+math.order accessors cpu.x86.assembler.syntax ;
-layouts math.order accessors cpu.x86.assembler.syntax ;
 IN: cpu.x86.assembler
 
-! A postfix assembler for x86 and AMD64.
+! A postfix assembler for x86-32 and x86-64.
 
 ! In 32-bit mode, { 1234 } is absolute indirect addressing.
 ! In 64-bit mode, { 1234 } is RIP-relative.
@@ -296,36 +295,23 @@ M: operand (MOV-I)
     { BIN: 000 t HEX: c6 }
     pick byte? [ immediate-1 ] [ immediate-4 ] if ;
 
-PREDICATE: callable < word register? not ;
-
 GENERIC: MOV ( dst src -- )
 M: immediate MOV swap (MOV-I) ;
-M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
 M: operand MOV HEX: 88 2-operand ;
 
 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;
 
 ! Control flow
 GENERIC: JMP ( op -- )
-: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
+M: integer JMP HEX: e9 , 4, ;
-M: f JMP (JMP) 2drop ;
-M: callable JMP (JMP) rel-word ;
-M: label JMP (JMP) label-fixup ;
 M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
-: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
+M: integer CALL HEX: e8 , 4, ;
-M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word-direct ;
-M: label CALL (CALL) label-fixup ;
 M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
+M: integer JUMPcc extended-opcode, 4, ;
-M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
-M: integer JUMPcc (JUMPcc) drop ;
-M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
-M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
 
 : JO  ( dst -- ) HEX: 80 JUMPcc ;
 : JNO ( dst -- ) HEX: 81 JUMPcc ;

basis/cpu/x86/bootstrap.factor

@@ -42,13 +42,18 @@ big-endian off
 ] jit-push-immediate jit-define
 
 [
-    f JMP rc-relative rt-xt jit-rel
+    temp3 0 MOV rc-absolute-cell rt-here jit-rel
+    0 JMP rc-relative rt-xt-pic-tail jit-rel
 ] jit-word-jump jit-define
 
 [
-    f CALL rc-relative rt-xt-direct jit-rel
+    0 CALL rc-relative rt-xt-pic jit-rel
 ] jit-word-call jit-define
 
+[
+    0 JMP rc-relative rt-xt jit-rel
+] jit-word-special jit-define
+
 [
     ! load boolean
     temp0 ds-reg [] MOV
@@ -57,13 +62,10 @@ big-endian off
     ! compare boolean with f
     temp0 \ f tag-number CMP
     ! jump to true branch if not equal
-    f JNE rc-relative rt-xt jit-rel
+    0 JNE rc-relative rt-xt jit-rel
-] jit-if-1 jit-define
-
-[
     ! jump to false branch if equal
-    f JMP rc-relative rt-xt jit-rel
+    0 JMP rc-relative rt-xt jit-rel
-] jit-if-2 jit-define
+] jit-if jit-define
 
 : jit->r ( -- )
     rs-reg bootstrap-cell ADD
@@ -115,19 +117,19 @@ big-endian off
 
 [
     jit->r
-    f CALL rc-relative rt-xt jit-rel
+    0 CALL rc-relative rt-xt jit-rel
     jit-r>
 ] jit-dip jit-define
 
 [
     jit-2>r
-    f CALL rc-relative rt-xt jit-rel
+    0 CALL rc-relative rt-xt jit-rel
     jit-2r>
 ] jit-2dip jit-define
 
 [
     jit-3>r
-    f CALL rc-relative rt-xt jit-rel
+    0 CALL rc-relative rt-xt jit-rel
     jit-3r>
 ] jit-3dip jit-define
 
@@ -152,8 +154,7 @@ big-endian off
 
 ! ! ! Polymorphic inline caches
 
-! temp0 contains the object being dispatched on
+! The PIC and megamorphic code stubs are not permitted to touch temp3.
-! temp1 contains its class
 
 ! Load a value from a stack position
 [
@@ -197,7 +198,7 @@ big-endian off
     [
         ! Untag temp0
         temp0 tag-mask get bitnot AND
-        ! Set temp1 to 0 for objects, and 8 for tuples
+        ! Set temp1 to 0 for objects, and bootstrap-cell for tuples
         temp1 1 tag-fixnum AND
         bootstrap-cell 4 = [ temp1 1 SHR ] when
         ! Load header cell or tuple layout cell
@@ -214,7 +215,7 @@ big-endian off
     temp1 temp2 CMP
 ] pic-check jit-define
 
-[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
+[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
 
 ! ! ! Megamorphic caches
 
@@ -232,12 +233,13 @@ big-endian off
     temp0 temp2 ADD
     ! if(get(cache) == class)
     temp0 [] temp1 CMP
-    ! ... goto get(cache + bootstrap-cell)
+    bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
-    [
+    ! megamorphic_cache_hits++
-        temp0 temp0 bootstrap-cell [+] MOV
+    temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
-        temp0 word-xt-offset [+] JMP
+    temp1 [] 1 ADD
-    ] [ ] make
+    ! goto get(cache + bootstrap-cell)
-    [ length JNE ] [ % ] bi
+    temp0 temp0 bootstrap-cell [+] MOV
+    temp0 word-xt-offset [+] JMP
     ! fall-through on miss
 ] mega-lookup jit-define
 

basis/cpu/x86/x86.factor

@@ -11,6 +11,10 @@ IN: cpu.x86
 
 << enable-fixnum-log2 >>
 
+! Add some methods to the assembler to be more useful to the backend
+M: label JMP 0 JMP rc-relative label-fixup ;
+M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
+
 M: x86 two-operand? t ;
 
 HOOK: temp-reg-1 cpu ( -- reg )
@@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
 HOOK: param-reg-1 cpu ( -- reg )
 HOOK: param-reg-2 cpu ( -- reg )
 
+HOOK: pic-tail-reg cpu ( -- reg )
+
 M: x86 %load-immediate MOV ;
 
 M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
@@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
     reserved-area-size +
     align-stack ;
 
-M: x86 %call ( label -- ) CALL ;
+M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
-M: x86 %jump-label ( label -- ) JMP ;
+
+: xt-tail-pic-offset ( -- n )
+    #! See the comment in vm/cpu-x86.hpp
+    cell 4 + 1 + ; inline
+
+M: x86 %jump ( word -- )
+    pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
+    0 JMP rc-relative rel-word-pic-tail ;
+
+M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
+
 M: x86 %return ( -- ) 0 RET ;
 
 : code-alignment ( align -- n )

basis/dlists/dlists-docs.factor

@@ -15,6 +15,7 @@ $nl
 "Iterating over elements:"
 { $subsection dlist-each }
 { $subsection dlist-find }
+{ $subsection dlist-filter }
 { $subsection dlist-any? }
 "Deleting a node matching a predicate:"
 { $subsection delete-node-if* }
@@ -40,6 +41,11 @@ HELP: dlist-find
     "This operation is O(n)."
 } ;
 
+HELP: dlist-filter
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
+{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
+{ $side-effects { "dlist" } } ;
+
 HELP: dlist-any?
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
 { $description "Just like " { $link dlist-find } " except it doesn't return the object." }

basis/dlists/dlists-tests.factor

@@ -79,3 +79,8 @@ IN: dlists.tests
 [ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
 
 [ V{ } ] [ <dlist> dlist>seq ] unit-test
+
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test

basis/dlists/dlists.factor

@@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-next drop
+            next>>
             f over set-prev-when
         ] change-front drop
     ] keep
@@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
     [
         [
             [ empty-dlist ] unless*
-            [ f ] change-prev drop
+            prev>>
             f over set-next-when
         ] change-back drop
     ] keep
@@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
 
 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 
+: dlist-filter ( dlist quot -- dlist )
+    over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
+
 M: dlist clone
     <dlist> [ '[ _ push-back ] dlist-each ] keep ;
 

basis/fry/fry-docs.factor

@@ -57,7 +57,6 @@ $nl
 "Here are some built-in combinators rewritten in terms of fried quotations:"
 { $table
     { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
-    { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
     { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
     { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
     { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }

basis/game-input/dinput/dinput.factor

@@ -5,16 +5,20 @@ windows.user32 windows.messages sequences combinators locals
 math.rectangles accessors math alien alien.strings
 io.encodings.utf16 io.encodings.utf16n continuations
 byte-arrays game-input.dinput.keys-array game-input
-ui.backend.windows windows.errors ;
+ui.backend.windows windows.errors struct-arrays
+math.bitwise ;
 IN: game-input.dinput
 
+CONSTANT: MOUSE-BUFFER-SIZE 16
+
 SINGLETON: dinput-game-input-backend
 
 dinput-game-input-backend game-input-backend set-global
 
 SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
     +controller-devices+ +controller-guids+
-    +device-change-window+ +device-change-handle+ ;
+    +device-change-window+ +device-change-handle+
+    +mouse-device+ +mouse-state+ +mouse-buffer+ ;
 
 : create-dinput ( -- )
     f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
@@ -35,8 +39,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
 : set-data-format ( device format-symbol -- )
     get IDirectInputDevice8W::SetDataFormat ole32-error ;
 
+: <buffer-size-diprop> ( size -- DIPROPDWORD )
+    "DIPROPDWORD" <c-object>
+        "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
+        "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
+        0 over set-DIPROPHEADER-dwObj
+        DIPH_DEVICE over set-DIPROPHEADER-dwHow
+        swap over set-DIPROPDWORD-dwData ;
+
+: set-buffer-size ( device size -- )
+    DIPROP_BUFFERSIZE swap <buffer-size-diprop>
+    IDirectInputDevice8W::SetProperty ole32-error ;
+
 : configure-keyboard ( keyboard -- )
     [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
+: configure-mouse ( mouse -- )
+    [ c_dfDIMouse2 set-data-format ]
+    [ MOUSE-BUFFER-SIZE set-buffer-size ]
+    [ set-coop-level ] tri ;
 : configure-controller ( controller -- )
     [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
 
@@ -47,6 +67,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
     256 <byte-array> <keys-array> keyboard-state boa
     +keyboard-state+ set-global ;
 
+: find-mouse ( -- )
+    GUID_SysMouse device-for-guid
+    [ configure-mouse ]
+    [ +mouse-device+ set-global ] bi
+    0 0 0 0 8 f <array> mouse-state boa
+    +mouse-state+ set-global
+    MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
+    +mouse-buffer+ set-global ;
+
 : device-info ( device -- DIDEVICEIMAGEINFOW )
     "DIDEVICEINSTANCEW" <c-object>
     "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
@@ -190,16 +219,22 @@ TUPLE: window-rect < rect window-loc ;
     +keyboard-device+ [ com-release f ] change-global
     f +keyboard-state+ set-global ;
 
+: release-mouse ( -- )
+    +mouse-device+ [ com-release f ] change-global
+    f +mouse-state+ set-global ;
+
 M: dinput-game-input-backend (open-game-input)
     create-dinput
     create-device-change-window
     find-keyboard
+    find-mouse
     set-up-controllers
     add-wm-devicechange ;
 
 M: dinput-game-input-backend (close-game-input)
     remove-wm-devicechange
     release-controllers
+    release-mouse
     release-keyboard
     close-device-change-window
     delete-dinput ;
@@ -263,6 +298,22 @@ CONSTANT: pov-values
         [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
     } 2cleave ;
 
+: read-device-buffer ( device buffer count -- buffer count' )
+    [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
+    [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
+
+: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
+    [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
+        { DIMOFS_X [ [ + ] curry change-dx ] }
+        { DIMOFS_Y [ [ + ] curry change-dy ] }
+        { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
+        [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
+    } case ;
+
+: fill-mouse-state ( buffer count -- state )
+    [ +mouse-state+ get ] 2dip swap
+    [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
+
 : get-device-state ( device byte-array -- )
     [ dup IDirectInputDevice8W::Poll ole32-error ] dip
     [ length ] keep
@@ -283,3 +334,17 @@ M: dinput-game-input-backend read-keyboard
     +keyboard-device+ get
     [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
     [ ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend read-mouse
+    +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+    [ fill-mouse-state ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend reset-mouse
+    +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+    [ 2drop ] [ ] with-acquisition
+    +mouse-state+ get
+        0 >>dx
+        0 >>dy
+        0 >>scroll-dx
+        0 >>scroll-dy
+        drop ;

basis/game-input/game-input-docs.factor

@@ -3,7 +3,7 @@ sequences strings math ;
 IN: game-input
 
 ARTICLE: "game-input" "Game controller input"
-"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl
+"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
 "The game input interface must be initialized before being used:"
 { $subsection open-game-input }
 { $subsection close-game-input }
@@ -18,17 +18,19 @@ ARTICLE: "game-input" "Game controller input"
 { $subsection instance-id }
 "A hook is provided for invoking the system calibration tool:"
 { $subsection calibrate-controller }
-"The current state of a controller or the keyboard can be read:"
+"The current state of a controller, the keyboard, and the mouse can be read:"
 { $subsection read-controller }
 { $subsection read-keyboard }
+{ $subsection read-mouse }
 { $subsection controller-state }
-{ $subsection keyboard-state } ;
+{ $subsection keyboard-state }
+{ $subsection mouse-state } ;
 
 HELP: open-game-input
-{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
+{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
 
 HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
 
 HELP: game-input-opened?
 { $values { "?" "a boolean" } }
@@ -86,6 +88,14 @@ HELP: read-keyboard
 { $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
 $nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
 
+HELP: read-mouse
+{ $values { "mouse-state" mouse-state } }
+{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
+
+HELP: reset-mouse
+{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
+
 HELP: controller-state
 { $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
 { $list
@@ -121,6 +131,19 @@ HELP: keyboard-state
 { $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
 { $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
 
+HELP: mouse-state
+{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
+{ $list
+    { { $snippet "dx" } " contains the mouse's X axis movement." }
+    { { $snippet "dy" } " contains the mouse's Y axis movement." }
+    { { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
+    { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
+    { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
+}
+"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
+} ;
+
+
 { keyboard-state read-keyboard } related-words
 
 ABOUT: "game-input"

basis/game-input/game-input-tests.factor

@@ -0,0 +1,8 @@
+IN: game-input.tests
+USING: ui game-input tools.test kernel system threads calendar ;
+
+os windows? os macosx? or [
+    [ ] [ open-game-input ] unit-test
+    [ ] [ 1 seconds sleep ] unit-test
+    [ ] [ close-game-input ] unit-test
+] when

basis/game-input/game-input.factor

@@ -1,38 +1,61 @@
-USING: arrays accessors continuations kernel system
+USING: arrays accessors continuations kernel math system
 sequences namespaces init vocabs vocabs.loader combinators ;
 IN: game-input
 
 SYMBOLS: game-input-backend game-input-opened ;
 
+game-input-opened [ 0 ] initialize
+
 HOOK: (open-game-input)  game-input-backend ( -- )
 HOOK: (close-game-input) game-input-backend ( -- )
 HOOK: (reset-game-input) game-input-backend ( -- )
 
+HOOK: get-controllers game-input-backend ( -- sequence )
+
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+HOOK: read-controller game-input-backend ( controller -- controller-state )
+HOOK: calibrate-controller game-input-backend ( controller -- )
+
+HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
 : game-input-opened? ( -- ? )
-    game-input-opened get ;
+    game-input-opened get zero? not ;
 
 <PRIVATE
 
 M: f (reset-game-input) ;
 
 : reset-game-input ( -- )
-    game-input-opened off
     (reset-game-input) ;
 
 [ reset-game-input ] "game-input" add-init-hook
 
 PRIVATE>
 
+ERROR: game-input-not-open ;
+
 : open-game-input ( -- )
     game-input-opened? [
         (open-game-input) 
-        game-input-opened on
+    ] unless
-    ] unless ;
+    game-input-opened [ 1+ ] change-global
+    reset-mouse ;
 : close-game-input ( -- )
+    game-input-opened [
+        dup zero? [ game-input-not-open ] when
+        1-
+    ] change-global
     game-input-opened? [
         (close-game-input) 
         reset-game-input
-    ] when ;
+    ] unless ;
 
 : with-game-input ( quot -- )
     open-game-input [ close-game-input ] [ ] cleanup ; inline
@@ -48,12 +71,6 @@ SYMBOLS:
     pov-up pov-up-right pov-right pov-down-right
     pov-down pov-down-left pov-left pov-up-left ;
 
-HOOK: get-controllers game-input-backend ( -- sequence )
-
-HOOK: product-string game-input-backend ( controller -- string )
-HOOK: product-id game-input-backend ( controller -- id )
-HOOK: instance-id game-input-backend ( controller -- id )
-
 : find-controller-products ( product-id -- sequence )
     get-controllers [ product-id = ] with filter ;
 : find-controller-instance ( product-id instance-id -- controller/f )
@@ -63,15 +80,15 @@ HOOK: instance-id game-input-backend ( controller -- id )
         [ instance-id = ] 2bi* and
     ] with with find nip ;
 
-HOOK: read-controller game-input-backend ( controller -- controller-state )
-HOOK: calibrate-controller game-input-backend ( controller -- )
-
 TUPLE: keyboard-state keys ;
 
 M: keyboard-state clone
     call-next-method dup keys>> clone >>keys ;
 
-HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
+
+M: mouse-state clone
+    call-next-method dup buttons>> clone >>buttons ;
 
 {
     { [ os windows? ] [ "game-input.dinput" require ] }

basis/game-input/iokit/iokit.factor

@@ -1,13 +1,15 @@
 USING: cocoa cocoa.plists core-foundation iokit iokit.hid
 kernel cocoa.enumeration destructors math.parser cocoa.application 
 sequences locals combinators.short-circuit threads
-namespaces assocs vectors arrays combinators
+namespaces assocs vectors arrays combinators hints alien
 core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input ;
+alien.c-types math parser game-input vectors ;
 IN: game-input.iokit
 
 SINGLETON: iokit-game-input-backend
 
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+
 iokit-game-input-backend game-input-backend set-global
 
 : hid-manager-matching ( matching-seq -- alien )
@@ -23,9 +25,12 @@ iokit-game-input-backend game-input-backend set-global
 
 CONSTANT: game-devices-matching-seq
     {
+        H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
         H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
         H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
         H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
+        H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
+        H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
     }
 
 CONSTANT: buttons-matching-hash
@@ -46,6 +51,8 @@ CONSTANT: rz-axis-matching-hash
     H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
 CONSTANT: slider-matching-hash
     H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
+CONSTANT: wheel-matching-hash
+    H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
 CONSTANT: hat-switch-matching-hash
     H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
 
@@ -82,44 +89,54 @@ CONSTANT: hat-switch-matching-hash
     game-devices-matching-seq hid-manager-matching ;
 
 : device-property ( device key -- value )
-    <NSString> IOHIDDeviceGetProperty plist> ;
+    <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
 : element-property ( element key -- value )
-    <NSString> IOHIDElementGetProperty plist> ;
+    <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
 : set-element-property ( element key value -- )
     [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
 : transfer-element-property ( element from-key to-key -- )
-    [ dupd element-property ] dip swap set-element-property ;
+    [ dupd element-property ] dip swap
+    [ set-element-property ] [ 2drop ] if* ;
+
+: mouse-device? ( device -- ? )
+    1 2 IOHIDDeviceConformsTo ;
 
 : controller-device? ( device -- ? )
     {
         [ 1 4 IOHIDDeviceConformsTo ]
         [ 1 5 IOHIDDeviceConformsTo ]
+        [ 1 8 IOHIDDeviceConformsTo ]
     } 1|| ;
 
 : element-usage ( element -- {usage-page,usage} )
     [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
     2array ;
 
-: button? ( {usage-page,usage} -- ? )
+: button? ( element -- ? )
-    first 9 = ; inline
+    IOHIDElementGetUsagePage 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
+: keyboard-key? ( element -- ? )
-    first 7 = ; inline
+    IOHIDElementGetUsagePage 7 = ; inline
+: axis? ( element -- ? )
+    IOHIDElementGetUsagePage 1 = ; inline
+
 : x-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 30 } = ; inline
+    IOHIDElementGetUsage HEX: 30 = ; inline
 : y-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 31 } = ; inline
+    IOHIDElementGetUsage HEX: 31 = ; inline
 : z-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 32 } = ; inline
+    IOHIDElementGetUsage HEX: 32 = ; inline
 : rx-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 33 } = ; inline
+    IOHIDElementGetUsage HEX: 33 = ; inline
 : ry-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 34 } = ; inline
+    IOHIDElementGetUsage HEX: 34 = ; inline
 : rz-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 35 } = ; inline
+    IOHIDElementGetUsage HEX: 35 = ; inline
 : slider? ( {usage-page,usage} -- ? )
-    { 1 HEX: 36 } = ; inline
+    IOHIDElementGetUsage HEX: 36 = ; inline
+: wheel? ( {usage-page,usage} -- ? )
+    IOHIDElementGetUsage HEX: 38 = ; inline
 : hat-switch? ( {usage-page,usage} -- ? )
-    { 1 HEX: 39 } = ; inline
+    IOHIDElementGetUsage HEX: 39 = ; inline
 
 CONSTANT: pov-values
     {
@@ -132,34 +149,70 @@ CONSTANT: pov-values
     IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
 : axis-value ( value -- [-1,1] )
     kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
+: mouse-axis-value ( value -- n )
+    IOHIDValueGetIntegerValue ;
 : pov-value ( value -- pov-direction )
     IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
 
+: record-button ( state hid-value element -- )
+    [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
+
 : record-controller ( controller-state value -- )
-    dup IOHIDValueGetElement element-usage {
+    dup IOHIDValueGetElement {
-        { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] } 
+        { [ dup button? ] [ record-button ] } 
-        { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+        { [ dup axis? ] [ {
-        { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+            { [ dup x-axis? ] [ drop axis-value >>x drop ] }
-        { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+            { [ dup y-axis? ] [ drop axis-value >>y drop ] }
-        { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+            { [ dup z-axis? ] [ drop axis-value >>z drop ] }
-        { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+            { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
-        { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+            { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
-        { [ dup slider? ] [ drop axis-value >>slider drop ] }
+            { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
-        { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+            { [ dup slider? ] [ drop axis-value >>slider drop ] }
+            { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+            [ 3drop ]
+        } cond ] }
         [ 3drop ]
     } cond ;
 
-SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
+HINTS: record-controller { controller-state alien } ;
 
 : ?set-nth ( value nth seq -- )
     2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
 
-: record-keyboard ( value -- )
+: record-keyboard ( keyboard-state value -- )
-    dup IOHIDValueGetElement element-usage keyboard-key? [
+    dup IOHIDValueGetElement dup keyboard-key? [
         [ IOHIDValueGetIntegerValue c-bool> ]
-        [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
+        [ IOHIDElementGetUsage ] bi*
-        +keyboard-state+ get ?set-nth
+        rot ?set-nth
-    ] [ drop ] if ;
+    ] [ 3drop ] if ;
+
+HINTS: record-keyboard { array alien } ;
+
+: record-mouse ( mouse-state value -- )
+    dup IOHIDValueGetElement {
+        { [ dup button? ] [ record-button ] }
+        { [ dup axis? ] [ {
+            { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
+            { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
+            { [ dup wheel?  ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
+            { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
+            [ 3drop ]
+        } cond ] }
+        [ 3drop ]
+    } cond ;
+
+HINTS: record-mouse { mouse-state alien } ;
+
+M: iokit-game-input-backend read-mouse
+    +mouse-state+ get ;
+
+M: iokit-game-input-backend reset-mouse
+    +mouse-state+ get
+        0 >>dx
+        0 >>dy
+        0 >>scroll-dx 
+        0 >>scroll-dy
+        drop ;
 
 : default-calibrate-saturation ( element -- )
     [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
@@ -194,12 +247,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
         [ button-count f <array> ]
     } cleave controller-state boa ;
 
+: ?add-mouse-buttons ( device -- )
+    button-count +mouse-state+ get buttons>> 
+    2dup length >
+    [ set-length ] [ 2drop ] if ;
+
 : device-matched-callback ( -- alien )
     [| context result sender device |
-        device controller-device? [
+        {
-            device <device-controller-state>
+            { [ device controller-device? ] [
-            device +controller-states+ get set-at
+                device <device-controller-state>
-        ] when
+                device +controller-states+ get set-at
+            ] }
+            { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
+            [ ]
+        } cond
     ] IOHIDDeviceCallback ;
 
 : device-removed-callback ( -- alien )
@@ -209,15 +271,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
 
 : device-input-callback ( -- alien )
     [| context result sender value |
-        sender controller-device?
+        {
-        [ sender +controller-states+ get at value record-controller ]
+            { [ sender controller-device? ] [
-        [ value record-keyboard ]
+                sender +controller-states+ get at value record-controller
-        if
+            ] }
+            { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
+            [ +keyboard-state+ get value record-keyboard ]
+        } cond
     ] IOHIDValueCallback ;
 
 : initialize-variables ( manager -- )
     +hid-manager+ set-global
     4 <vector> +controller-states+ set-global
+    0 0 0 0 2 <vector> mouse-state boa
+        +mouse-state+ set-global
     256 f <array> +keyboard-state+ set-global ;
 
 M: iokit-game-input-backend (open-game-input)
@@ -234,7 +301,7 @@ M: iokit-game-input-backend (open-game-input)
     } cleave ;
 
 M: iokit-game-input-backend (reset-game-input)
-    { +hid-manager+ +keyboard-state+ +controller-states+ }
+    { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
     [ f swap set-global ] each ;
 
 M: iokit-game-input-backend (close-game-input)
@@ -249,6 +316,7 @@ M: iokit-game-input-backend (close-game-input)
             f
         ] change-global
         f +keyboard-state+ set-global
+        f +mouse-state+ set-global
         f +controller-states+ set-global
     ] when ;
 

basis/generalizations/generalizations-docs.factor

@@ -161,22 +161,6 @@ HELP: ndip
     }
 } ;
 
-HELP: nslip
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link slip } " that can work " 
-"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
-"removed from the stack, the quotation called, and the items restored."
-} 
-{ $examples
-  { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }
-  "Some core words expressed in terms of " { $link nslip } ":"
-    { $table
-        { { $link slip } { $snippet "1 nslip" } }
-        { { $link 2slip } { $snippet "2 nslip" } }
-        { { $link 3slip } { $snippet "3 nslip" } }
-    }
-} ;
-
 HELP: nkeep
 { $values { "quot" quotation } { "n" integer } }
 { $description "A generalization of " { $link keep } " that can work " 
@@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
 
 ARTICLE: "combinator-generalizations" "Generalized combinators"
 { $subsection ndip }
-{ $subsection nslip }
 { $subsection nkeep }
 { $subsection napply }
 { $subsection ncleave }

basis/generalizations/generalizations-tests.factor

@@ -26,8 +26,6 @@ IN: generalizations.tests
 [ [ 1 ] 5 ndip ] must-infer
 [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
 
-[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
-{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
 [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test

basis/generalizations/generalizations.factor

@@ -60,9 +60,6 @@ MACRO: ntuck ( n -- )
 MACRO: ndip ( quot n -- )
     [ '[ _ dip ] ] times ;
 
-MACRO: nslip ( n -- )
-    '[ [ call ] _ ndip ] ;
-
 MACRO: nkeep ( quot n -- )
     tuck '[ _ ndup _ _ ndip ] ;
 

basis/help/lint/lint.factor

@@ -87,7 +87,7 @@ PRIVATE>
 
 : help-lint-all ( -- ) "" help-lint ;
 
-: :lint-failures ( -- ) lint-failures get errors. ;
+: :lint-failures ( -- ) lint-failures get values errors. ;
 
 : unlinked-words ( words -- seq )
     all-word-help [ article-parent not ] filter ;

basis/images/tiff/tiff.factor

@@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
 io.binary io.encodings.ascii io.encodings.binary
 io.encodings.string io.encodings.utf8 io.files kernel math
 math.bitwise math.order math.parser pack prettyprint sequences
-strings math.vectors specialized-arrays.float ;
+strings math.vectors specialized-arrays.float locals ;
 IN: images.tiff
 
 TUPLE: tiff-image < image ;
@@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation
 software date-time photoshop exif-ifd sub-ifd inter-color-profile
 xmp iptc fill-order document-name page-number page-name
 x-position y-position host-computer copyright artist
-min-sample-value max-sample-value make model cell-width cell-length
+min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
 gray-response-unit gray-response-curve color-map threshholding
 image-description free-offsets free-byte-counts tile-width tile-length
 matteing data-type image-depth tile-depth
@@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ;
 
 ERROR: no-tag class ;
 
-: find-tag ( idf class -- tag )
+: find-tag* ( ifd class -- tag/class ? )
-    swap processed-tags>> ?at [ no-tag ] unless ;
+    swap processed-tags>> ?at ;
 
-: tag? ( idf class -- tag )
+: find-tag ( ifd class -- tag )
+    find-tag* [ no-tag ] unless ;
+
+: tag? ( ifd class -- tag )
     swap processed-tags>> key? ;
 
 : read-strips ( ifd -- ifd )
@@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ;
         { 266 [ fill-order ] }
         { 269 [ ascii decode document-name ] }
         { 270 [ ascii decode image-description ] }
-        { 271 [ ascii decode make ] }
+        { 271 [ ascii decode tiff-make ] }
-        { 272 [ ascii decode model ] }
+        { 272 [ ascii decode tiff-model ] }
         { 273 [ strip-offsets ] }
         { 274 [ orientation ] }
         { 277 [ samples-per-pixel ] }
@@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ;
         { 281 [ max-sample-value ] }
         { 282 [ first x-resolution ] }
         { 283 [ first y-resolution ] }
-        { 284 [ planar-configuration ] }
+        { 284 [ lookup-planar-configuration planar-configuration ] }
         { 285 [ page-name ] }
         { 286 [ x-position ] }
         { 287 [ y-position ] }
@@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ;
     [ samples-per-pixel find-tag ] tri
     [ * ] keep
     '[
-        _ group [ _ group [ rest ] [ first ] bi
+        _ group
-        [ v+ ] accumulate swap suffix concat ] map
+        [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
         concat >byte-array
     ] change-bitmap ;
 
@@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ;
         ] with-tiff-endianness
     ] with-file-reader ;
 
-: process-tif-ifds ( parsed-tiff -- parsed-tiff )
+: process-chunky-ifd ( ifd -- )
-    dup ifds>> [
+    read-strips
-        read-strips
+    uncompress-strips
-        uncompress-strips
+    strips>bitmap
-        strips>bitmap
+    fix-bitmap-endianness
-        fix-bitmap-endianness
+    strips-predictor
-        strips-predictor
+    dup extra-samples tag? [ handle-alpha-data ] when
-        dup extra-samples tag? [ handle-alpha-data ] when
+    drop ;
-        drop
+
-    ] each ;
+: process-planar-ifd ( ifd -- )
+    "planar ifd not supported" throw ;
+
+: dispatch-planar-configuration ( ifd planar-configuration -- )
+    {
+        { planar-configuration-chunky [ process-chunky-ifd ] }
+        { planar-configuration-planar [ process-planar-ifd ] }
+    } case ;
+
+: process-ifd ( ifd -- )
+    dup planar-configuration find-tag* [
+        dispatch-planar-configuration
+    ] [
+        drop "no planar configuration" throw
+    ] if ;
+
+: process-tif-ifds ( parsed-tiff -- )
+    ifds>> [ process-ifd ] each ;
 
 : load-tiff ( path -- parsed-tiff )
-    [ load-tiff-ifds ] [
+    [ load-tiff-ifds dup ] keep
-        binary [
+    binary [
-            [ process-tif-ifds ] with-tiff-endianness
+        [ process-tif-ifds ] with-tiff-endianness
-        ] with-file-reader
+    ] with-file-reader ;
-    ] bi ;
 
 ! tiff files can store several images -- we just take the first for now
 M: tiff-image load-image* ( path tiff-image -- image )

basis/io/backend/unix/unix.factor

@@ -173,10 +173,11 @@ M: stdin refill
         size-read-fd <fd> init-fd <input-port> >>size
         data-read-fd <fd> >>data ;
 
-M: unix (init-stdio)
+M: unix init-stdio
     <stdin> <input-port>
     1 <fd> <output-port>
-    2 <fd> <output-port> t ;
+    2 <fd> <output-port>
+    set-stdio ;
 
 ! mx io-task for embedding an fd-based mx inside another mx
 TUPLE: mx-port < port mx ;

basis/io/backend/windows/nt/nt.factor

@@ -1,9 +1,9 @@
-USING: alien alien.c-types arrays assocs combinators
+USING: alien alien.c-types arrays assocs combinators continuations
-continuations destructors io io.backend io.ports io.timeouts
+destructors io io.backend io.ports io.timeouts io.backend.windows
-io.backend.windows io.files.windows io.files.windows.nt io.files
+io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
-io.pathnames io.buffers io.streams.c libc kernel math namespaces
+io.streams.c io.streams.null libc kernel math namespaces sequences
-sequences threads windows windows.errors windows.kernel32
+threads windows windows.errors windows.kernel32 strings splitting
-strings splitting ascii system accessors locals ;
+ascii system accessors locals ;
 QUALIFIED: windows.winsock
 IN: io.backend.windows.nt
 
@@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- )
 
 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
 
-M: winnt (init-stdio)
+M: winnt init-stdio
-    console-app? [ init-c-stdio t ] [ f f f f ] if ;
+    console-app?
+    [ init-c-stdio ]
+    [ null-reader null-writer null-writer set-stdio ] if ;
 
 winnt set-io-backend

basis/io/backend/windows/privileges/privileges-tests.factor

@@ -0,0 +1,4 @@
+IN: io.backend.windows.privileges.tests
+USING: io.backend.windows.privileges tools.test ;
+
+[ [ ] with-privileges ] must-infer

basis/io/backend/windows/privileges/privileges.factor

@@ -1,12 +1,13 @@
 USING: io.backend kernel continuations sequences
-system vocabs.loader combinators ;
+system vocabs.loader combinators fry ;
 IN: io.backend.windows.privileges
 
-HOOK: set-privilege io-backend ( name ? -- ) inline
+HOOK: set-privilege io-backend ( name ? -- )
 
 : with-privileges ( seq quot -- )
-    over [ [ t set-privilege ] each ] curry compose
+    [ '[ _ [ t set-privilege ] each @ ] ]
-    swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
+    [ drop '[ _ [ f set-privilege ] each ] ]
+    2bi [ ] cleanup ; inline
 
 {
     { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }

basis/io/directories/hierarchy/hierarchy.factor

@@ -20,7 +20,7 @@ DEFER: copy-tree-into
     {
         { +symbolic-link+ [ copy-link ] }
         { +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] }
-        [ drop copy-file ]
+        [ drop copy-file-and-info ]
     } case ;
 
 : copy-tree-into ( from to -- )

basis/io/directories/search/search-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations sequences ;
 IN: io.directories.search
 
 HELP: each-file
@@ -57,6 +57,32 @@ HELP: find-all-in-directories
 }
 { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
 
+HELP: find-by-extension
+{ $values
+    { "path" "a pathname string" } { "extension" "a file extension" }
+    { "seq" sequence }
+}
+{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
+{ $examples
+    { $unchecked-example
+        "USING: io.directories.search ;"
+        "\"/\" \".mp3\" find-by-extension"
+    }
+} ;
+
+HELP: find-by-extensions
+{ $values
+    { "path" "a pathname string" } { "extensions" "a sequence of file extensions" }
+    { "seq" sequence }
+}
+{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
+{ $examples
+    { $unchecked-example
+        "USING: io.directories.search ;"
+        "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
+    }
+} ;
+
 { find-file find-all-files find-in-directories find-all-in-directories } related-words
 
 ARTICLE: "io.directories.search" "Searching directories"
@@ -65,10 +91,13 @@ ARTICLE: "io.directories.search" "Searching directories"
 { $subsection recursive-directory-files }
 { $subsection recursive-directory-entries }
 { $subsection each-file }
-"Finding files:"
+"Finding files by name:"
 { $subsection find-file }
 { $subsection find-all-files }
 { $subsection find-in-directories }
-{ $subsection find-all-in-directories } ;
+{ $subsection find-all-in-directories }
+"Finding files by extension:"
+{ $subsection find-by-extension }
+{ $subsection find-by-extensions } ;
 
 ABOUT: "io.directories.search"

basis/io/directories/search/search.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays continuations deques dlists fry
 io.directories io.files io.files.info io.pathnames kernel
 sequences system vocabs.loader locals math namespaces
-sorting assocs calendar threads io math.parser ;
+sorting assocs calendar threads io math.parser unicode.case ;
 IN: io.directories.search
 
 : qualified-directory-entries ( path -- seq )
@@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ;
         ] { } map>assoc
     ] with-qualified-directory-entries sort-values ;
 
+: find-by-extensions ( path extensions -- seq )
+    [ >lower ] map
+    '[ >lower _ [ tail? ] with any? ] find-all-files ;
+    
+: find-by-extension ( path extension -- seq )
+    1array find-by-extensions ;
+
 os windows? [ "io.directories.search.windows" require ] when

basis/io/directories/unix/linux/linux.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.directories.unix kernel system unix ;
+IN: io.directories.unix.linux
+
+M: unix find-next-file ( DIR* -- byte-array )
+    "dirent" <c-object>
+    f <void*>
+    [ readdir64_r 0 = [ (io-error) ] unless ] 2keep
+    *void* [ drop f ] unless ;

basis/io/directories/unix/unix.factor

@@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
 continuations destructors fry io io.backend io.backend.unix
 io.directories io.encodings.binary io.encodings.utf8 io.files
 io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat ;
+unix unix.stat vocabs.loader ;
 IN: io.directories.unix
 
 : touch-mode ( -- n )
@@ -34,7 +34,9 @@ M: unix copy-file ( from to -- )
     [ opendir dup [ (io-error) ] unless ] dip
     dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
 
-: find-next-file ( DIR* -- byte-array )
+HOOK: find-next-file os ( DIR* -- byte-array )
+
+M: unix find-next-file ( DIR* -- byte-array )
     "dirent" <c-object>
     f <void*>
     [ readdir_r 0 = [ (io-error) ] unless ] 2keep
@@ -54,8 +56,10 @@ M: unix copy-file ( from to -- )
     } case ;
 
 M: unix >directory-entry ( byte-array -- directory-entry )
-    [ dirent-d_name utf8 alien>string ]
+    {
-    [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
+        [ dirent-d_name utf8 alien>string ]
+        [ dirent-d_type dirent-type>file-type ]
+    } cleave directory-entry boa ;
 
 M: unix (directory-entries) ( path -- seq )
     [
@@ -63,3 +67,5 @@ M: unix (directory-entries) ( path -- seq )
         [ >directory-entry ]
         produce nip
     ] with-unix-directory ;
+
+os linux? [ "io.directories.unix.linux" require ] when

basis/io/files/info/info.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel system sequences combinators
-vocabs.loader io.files.types ;
+vocabs.loader io.files.types io.directories math ;
 IN: io.files.info
 
 ! File info
@@ -14,6 +14,9 @@ HOOK: link-info os ( path -- info )
 
 : directory? ( file-info -- ? ) type>> +directory+ = ;
 
+: sparse-file? ( file-info -- ? )
+    [ size-on-disk>> ] [ size>> ] bi < ;
+
 ! File systems
 HOOK: file-systems os ( -- array )
 
@@ -26,3 +29,7 @@ HOOK: file-system-info os ( path -- file-system-info )
     { [ os unix? ] [ "io.files.info.unix." os name>> append ] }
     { [ os windows? ] [ "io.files.info.windows" ] }
 } cond require
+
+HOOK: copy-file-and-info os ( from to -- )
+
+M: object copy-file-and-info copy-file ;

basis/io/files/info/unix/unix.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel system math math.bitwise strings arrays
 sequences combinators combinators.short-circuit alien.c-types
 vocabs.loader calendar calendar.unix io.files.info
-io.files.types io.backend unix unix.stat unix.time unix.users
+io.files.types io.backend io.directories unix unix.stat unix.time unix.users
 unix.groups ;
 IN: io.files.info.unix
 
@@ -174,6 +174,9 @@ CONSTANT: OTHER-EXECUTE OCT: 0000001
 : file-permissions ( path -- n )
     normalize-path file-info permissions>> ;
 
+M: unix copy-file-and-info ( from to -- )
+    [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
+
 <PRIVATE
 
 : make-timeval-array ( array -- byte-array )

basis/io/files/unique/unique.factor

@@ -35,6 +35,9 @@ SYMBOL: unique-retries
 : random-name ( -- string )
     unique-length get [ random-ch ] "" replicate-as ;
 
+: retry ( quot: ( -- ? )  n -- )
+    swap [ drop ] prepose attempt-all ; inline
+
 : (make-unique-file) ( path prefix suffix -- path )
     '[
         _ _ _ random-name glue append-path

basis/io/launcher/launcher.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel namespaces strings hashtables sequences 
+USING: system kernel namespaces strings hashtables sequences assocs
-assocs combinators vocabs.loader init threads continuations
+combinators vocabs.loader init threads continuations math accessors
-math accessors concurrency.flags destructors environment
+concurrency.flags destructors environment io io.encodings.ascii
-io io.encodings.ascii io.backend io.timeouts io.pipes
+io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.pipes.private io.encodings io.streams.duplex io.ports
+io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
-debugger prettyprint summary calendar ;
+summary calendar ;
 IN: io.launcher
 
 TUPLE: process < identity-tuple
@@ -254,6 +254,21 @@ M: object run-pipeline-element
     swap [ with-stream ] dip
     wait-for-success ; inline
 
+ERROR: output-process-error { output string } { process process } ;
+
+M: output-process-error error.
+    [ "Process:" print process>> . nl ]
+    [ "Output:" print output>> print ]
+    bi ;
+
+: try-output-process ( command -- )
+    >process
+    +stdout+ >>stderr
+    +closed+ >>stdin
+    utf8 <process-reader*>
+    [ stream-contents ] [ dup wait-for-process ] bi*
+    0 = [ 2drop ] [ output-process-error ] if ;
+
 : notify-exit ( process status -- )
     >>status
     [ processes get delete-at* drop [ resume ] each ] keep

basis/io/launcher/unix/unix-tests.factor

@@ -48,7 +48,7 @@ concurrency.promises threads unix.process ;
     try-process
 ] unit-test
 
-[ f ] [
+[ "" ] [
     "cat"
     "launcher-test-1" temp-file
     2array

basis/io/launcher/windows/nt/nt-tests.factor

@@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
         console-vm "-run=listener" 2array >>command
         +closed+ >>stdin
         +stdout+ >>stderr
-    ascii [ input-stream get contents ] with-process-reader
+    ascii [ contents ] with-process-reader
 ] unit-test
 
 : launcher-test-path ( -- str )
@@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
         <process>
             console-vm "-script" "stderr.factor" 3array >>command
             "err2.txt" temp-file >>stderr
-        ascii <process-reader> lines first
+        ascii <process-reader> stream-lines first
     ] with-directory
 ] unit-test
 
@@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
     launcher-test-path [
         <process>
             console-vm "-script" "env.factor" 3array >>command
-        ascii <process-reader> contents
+        ascii <process-reader> stream-contents
     ] with-directory eval( -- alist )
 
     os-envs =
@@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
             console-vm "-script" "env.factor" 3array >>command
             +replace-environment+ >>environment-mode
             os-envs >>environment
-        ascii <process-reader> contents
+        ascii <process-reader> stream-contents
     ] with-directory eval( -- alist )
     
     os-envs =
@@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
         <process>
             console-vm "-script" "env.factor" 3array >>command
             { { "A" "B" } } >>environment
-        ascii <process-reader> contents
+        ascii <process-reader> stream-contents
     ] with-directory eval( -- alist )
 
     "A" swap at
@@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
             console-vm "-script" "env.factor" 3array >>command
             { { "USERPROFILE" "XXX" } } >>environment
             +prepend-environment+ >>environment-mode
-        ascii <process-reader> contents
+        ascii <process-reader> stream-contents
     ] with-directory eval( -- alist )
 
     "USERPROFILE" swap at "XXX" =

basis/io/streams/string/string-tests.factor

@@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make
 tools.test ;
 IN: io.streams.string.tests
 
+[ "" ] [ "" [ contents ] with-string-reader ] unit-test
+
 [ "line 1" CHAR: l ]
 [
     "line 1\nline 2\nline 3" <string-reader>