Merge branch 'master' of git://factorcode.org/git/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/c-types/c-types.factor

@@ -409,10 +409,10 @@ CONSTANT: primitive-types
     "uchar" define-primitive-type
 
     <c-type>
-        [ alien-unsigned-4 zero? not ] >>getter
+        [ alien-unsigned-1 zero? not ] >>getter
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
+        [ [ 1 0 ? ] 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/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 )
@@ -93,24 +93,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 +123,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 +307,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
@@ -510,11 +467,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 +477,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 +500,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/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 ;
 

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/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
-: 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/optimizer.factor

@@ -389,4 +389,10 @@ 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

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/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/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 ;
 
@@ -50,15 +50,12 @@ CONSTANT: rs-reg 30
     0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
     7 6 0 LWZ
     1 7 0 STW
-] jit-save-stack jit-define
-
-[
     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
 
@@ -68,11 +65,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 +132,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 +150,96 @@ CONSTANT: rs-reg 30
 
 [ BLR ] jit-return jit-define
 
-! Sub-primitives
+! ! ! Polymorphic inline caches
+
+! 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
+    5 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 +250,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,38 @@
-! 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.c-types literals cpu.architecture cpu.ppc.assembler
-compiler.cfg.registers compiler.cfg.instructions
+literals compiler.cfg.registers compiler.cfg.instructions
 compiler.constants compiler.codegen compiler.codegen.fixup
 compiler.cfg.intrinsics compiler.cfg.stack-frame ;
 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 +45,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 +113,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 3 LOAD32 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 ;
 

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 18 ? 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/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/literals/literals-docs.factor

@@ -21,7 +21,7 @@ CONSTANT: five 5
 USING: kernel literals prettyprint ;
 IN: scratchpad
 
-<< : seven-eleven ( -- a b ) 7 11 ; >>
+: seven-eleven ( -- a b ) 7 11 ;
 { $ seven-eleven } .
     "> "{ 7 11 }" }
 
@@ -43,7 +43,24 @@ IN: scratchpad
 
 } ;
 
-{ POSTPONE: $ POSTPONE: $[ } related-words
+HELP: ${
+{ $syntax "${ code }" }
+{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." }
+{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
+{ $examples
+
+    { $example <"
+USING: kernel literals math prettyprint ;
+IN: scratchpad
+
+CONSTANT: five 5
+CONSTANT: six 6
+${ five six 7 } .
+    "> "{ 5 6 7 }"
+    }
+} ;
+
+{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
 
 ARTICLE: "literals" "Interpolating code results into literal values"
 "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
@@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values"
 USING: kernel literals math prettyprint ;
 IN: scratchpad
 
-<< CONSTANT: five 5 >>
+CONSTANT: five 5
 { $ five $[ five dup 1+ dup 2 + ] } .
     "> "{ 5 5 6 8 }" }
 { $subsection POSTPONE: $ }
 { $subsection POSTPONE: $[ }
+{ $subsection POSTPONE: ${ }
 ;
 
 ABOUT: "literals"

basis/literals/literals-tests.factor

@@ -20,8 +20,10 @@ IN: literals.tests
 
 [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
 
-<<
 CONSTANT: constant-a 3
->>
 
 [ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test
+
+: sixty-nine ( -- a b ) 6 9 ;
+
+[ { 6 9 } ] [ ${ sixty-nine } ] unit-test

basis/literals/literals.factor

@@ -1,8 +1,21 @@
 ! (c) Joe Groff, see license for details
 USING: accessors continuations kernel parser words quotations
-combinators.smart vectors sequences ;
+combinators.smart vectors sequences fry ;
 IN: literals
 
-SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
+<PRIVATE
+
+! Use def>> call so that CONSTANT:s defined in the same file can
+! be called
+
+: expand-literal ( seq obj -- seq' )
+    '[ _ dup word? [ def>> call ] when ] with-datastack ;
+
+: expand-literals ( seq -- seq' )
+    [ [ { } ] dip expand-literal ] map concat ;
+
+PRIVATE>
+
+SYNTAX: $ scan-word expand-literal >vector ;
 SYNTAX: $[ parse-quotation with-datastack >vector ;
-SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;
+SYNTAX: ${ \ } [ expand-literals ] parse-literal ;

basis/math/bits/bits.factor

@@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ;
 C: <bits> bits
 
 : make-bits ( number -- bits )
-    dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
+    dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
 
 M: bits length length>> ;
 

basis/math/bitwise/bitwise.factor

@@ -13,10 +13,10 @@ IN: math.bitwise
 : unmask? ( x n -- ? ) unmask 0 > ; inline
 : mask ( x n -- ? ) bitand ; inline
 : mask? ( x n -- ? ) mask 0 > ; inline
-: wrap ( m n -- m' ) 1- bitand ; inline
+: wrap ( m n -- m' ) 1 - bitand ; inline
 : bits ( m n -- m' ) 2^ wrap ; inline
 : mask-bit ( m n -- m' ) 2^ mask ; inline
-: on-bits ( n -- m ) 2^ 1- ; inline
+: on-bits ( n -- m ) 2^ 1 - ; inline
 : toggle-bit ( m n -- m' ) 2^ bitxor ; inline
 
 : shift-mod ( n s w -- n )
@@ -64,8 +64,8 @@ DEFER: byte-bit-count
 <<
 
 \ byte-bit-count
-256 [
+256 iota [
-    8 <bits> 0 [ [ 1+ ] when ] reduce
+    8 <bits> 0 [ [ 1 + ] when ] reduce
 ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
 (( byte -- table )) define-declared
 
@@ -97,12 +97,12 @@ PRIVATE>
 
 ! Signed byte array to integer conversion
 : signed-le> ( bytes -- x )
-    [ le> ] [ length 8 * 1- on-bits ] bi
+    [ le> ] [ length 8 * 1 - on-bits ] bi
     2dup > [ bitnot bitor ] [ drop ] if ;
 
 : signed-be> ( bytes -- x )
     <reversed> signed-le> ;
 
 : >signed ( x n -- y )
-    2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
+    2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 

basis/math/blas/vectors/vectors.factor

@@ -164,7 +164,7 @@ M: VECTOR element-type
 M: VECTOR Vswap
     (prepare-swap) [ XSWAP ] 2dip ;
 M: VECTOR Viamax
-    (prepare-nrm2) IXAMAX 1- ;
+    (prepare-nrm2) IXAMAX 1 - ;
 
 M: VECTOR (blas-vector-like)
     drop <VECTOR> ;

basis/math/constants/constants.factor

@@ -7,6 +7,7 @@ IN: math.constants
 : euler ( -- gamma ) 0.57721566490153286060 ; inline
 : phi ( -- phi ) 1.61803398874989484820 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
+: 2pi ( -- pi ) 2 pi * ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
 : smallest-float ( -- x ) HEX: 1 bits>double ; foldable
 : largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

basis/math/functions/functions-tests.factor

@@ -157,3 +157,8 @@ IN: math.functions.tests
     2135623355842621559
     [ >bignum ] tri@ ^mod
 ] unit-test
+
+[ 1.0  ] [ 1.0 2.5 0.0 lerp ] unit-test
+[ 2.5  ] [ 1.0 2.5 1.0 lerp ] unit-test
+[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test
+

basis/math/functions/functions.factor

@@ -18,12 +18,12 @@ M: real sqrt
 : factor-2s ( n -- r s )
     #! factor an integer into 2^r * s
     dup 0 = [ 1 ] [
-        0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
+        0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
     ] if ; inline
 
 <PRIVATE
 
-GENERIC# ^n 1 ( z w -- z^w )
+GENERIC# ^n 1 ( z w -- z^w ) foldable
 
 : (^n) ( z w -- z^w )
     make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
@@ -216,17 +216,17 @@ M: real tanh ftanh ;
 : coth ( x -- y ) tanh recip ; inline
 
 : acosh ( x -- y )
-    dup sq 1- sqrt + log ; inline
+    dup sq 1 - sqrt + log ; inline
 
 : asech ( x -- y ) recip acosh ; inline
 
 : asinh ( x -- y )
-    dup sq 1+ sqrt + log ; inline
+    dup sq 1 + sqrt + log ; inline
 
 : acosech ( x -- y ) recip asinh ; inline
 
 : atanh ( x -- y )
-    [ 1+ ] [ 1- neg ] bi / log 2 / ; inline
+    [ 1 + ] [ 1 - neg ] bi / log 2 / ; inline
 
 : acoth ( x -- y ) recip atanh ; inline
 
@@ -259,6 +259,9 @@ M: real atan fatan ;
 
 : floor ( x -- y )
     dup 1 mod dup zero?
-    [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
+    [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
 
 : ceiling ( x -- y ) neg floor neg ; foldable
+
+: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
+

basis/math/intervals/intervals.factor

@@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
 
+: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+
 : [-inf,inf] ( -- interval ) full-interval ; inline
 
 : compare-endpoints ( p1 p2 quot -- ? )
@@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval-abs ( i1 -- i2 )
     {
         { [ dup empty-interval eq? ] [ ] }
-        { [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
+        { [ dup full-interval eq? ] [ drop [0,inf] ] }
         { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
         [ (interval-abs) points>interval ]
     } cond ;
@@ -376,11 +378,11 @@ SYMBOL: incomparable
 : interval-log2 ( i1 -- i2 )
     {
         { empty-interval [ empty-interval ] }
-        { full-interval [ 0 [a,inf] ] }
+        { full-interval [ [0,inf] ] }
         [
             to>> first 1 max dup most-positive-fixnum >
             [ drop full-interval interval-log2 ]
-            [ 1+ >integer log2 0 swap [a,b] ]
+            [ 1 + >integer log2 0 swap [a,b] ]
             if
         ]
     } case ;
@@ -407,7 +409,7 @@ SYMBOL: incomparable
 
 : integral-closure ( i1 -- i2 )
     dup special-interval? [
-        [ from>> first2 [ 1+ ] unless ]
+        [ from>> first2 [ 1 + ] unless ]
-        [ to>> first2 [ 1- ] unless ]
+        [ to>> first2 [ 1 - ] unless ]
         bi [a,b]
     ] unless ;

basis/math/miller-rabin/miller-rabin-docs.factor

@@ -0,0 +1,100 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences math ;
+IN: math.miller-rabin
+
+HELP: find-relative-prime
+{ $values
+    { "n" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
+
+HELP: find-relative-prime*
+{ $values
+    { "n" integer } { "guess" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
+
+HELP: miller-rabin
+{ $values
+    { "n" integer }
+    { "?" "a boolean" }
+}
+{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
+
+{ miller-rabin miller-rabin* } related-words
+
+HELP: miller-rabin*
+{ $values
+    { "n" integer } { "numtrials" integer }
+    { "?" "a boolean" }
+}
+{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
+
+HELP: next-prime
+{ $values
+    { "n" integer }
+    { "p" integer }
+}
+{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
+
+HELP: next-safe-prime
+{ $values
+    { "n" integer }
+    { "q" integer }
+}
+{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
+
+HELP: random-bits*
+{ $values
+    { "numbits" integer }
+    { "n" integer }
+}
+{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
+
+HELP: random-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: random-safe-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: safe-prime?
+{ $values
+    { "q" integer }
+    { "?" "a boolean" }
+}
+{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
+
+HELP: unique-primes
+{ $values
+    { "numbits" integer } { "n" integer }
+    { "seq" sequence }
+}
+{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
+
+ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
+"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
+"The Miller-Rabin probabilistic primality test:"
+{ $subsection miller-rabin }
+{ $subsection miller-rabin* }
+"Generating relative prime numbers:"
+{ $subsection find-relative-prime }
+{ $subsection find-relative-prime* }
+"Generating prime numbers:"
+{ $subsection next-prime }
+{ $subsection random-prime }
+"Generating safe prime numbers:"
+{ $subsection next-safe-prime }
+{ $subsection random-safe-prime } ;
+
+ABOUT: "math.miller-rabin"

basis/math/miller-rabin/miller-rabin-tests.factor

@@ -1,4 +1,5 @@
-USING: math.miller-rabin tools.test ;
+USING: math.miller-rabin tools.test kernel sequences
+math.miller-rabin.private math ;
 IN: math.miller-rabin.tests
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
@@ -6,6 +7,23 @@ IN: math.miller-rabin.tests
 [ t ] [ 3 miller-rabin ] unit-test
 [ f ] [ 36 miller-rabin ] unit-test
 [ t ] [ 37 miller-rabin ] unit-test
+[ 2 ] [ 1 next-prime ] unit-test
+[ 3 ] [ 2 next-prime ] unit-test
+[ 5 ] [ 3 next-prime ] unit-test
 [ 101 ] [ 100 next-prime ] unit-test
 [ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+
+[ 863 ] [ 862 next-safe-prime ] unit-test
+[ f ] [ 862 safe-prime? ] unit-test
+[ t ] [ 7 safe-prime? ] unit-test
+[ f ] [ 31 safe-prime? ] unit-test
+[ t ] [ 47 safe-prime-candidate? ] unit-test
+[ t ] [ 47 safe-prime? ] unit-test
+[ t ] [ 863 safe-prime? ] unit-test
+
+[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
+
+[ 47 ] [ 31 next-safe-prime ] unit-test
+[ 49 ] [ 50 random-prime log2 ] unit-test
+[ 49 ] [ 50 random-bits* log2 ] unit-test

basis/math/miller-rabin/miller-rabin.factor

@@ -1,37 +1,40 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators kernel locals math math.functions math.ranges
-random sequences sets ;
+random sequences sets combinators.short-circuit math.bitwise
+math math.order ;
 IN: math.miller-rabin
 
 <PRIVATE
 
-: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
+: >odd ( n -- int ) 0 set-bit ; foldable
+
+: >even ( n -- int ) 0 clear-bit ; foldable
+
+: next-even ( m -- n ) >even 2 + ;
+
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
 
 TUPLE: positive-even-expected n ;
 
 :: (miller-rabin) ( n trials -- ? )
-    [let | r [ n 1- factor-2s drop ]
+    n 1 - :> n-1
-           s [ n 1- factor-2s nip ]
+    n-1 factor-2s :> s :> r
-           prime?! [ t ]
+    0 :> a!
-           a! [ 0 ]
+    trials [
-           count! [ 0 ] |
+        drop
-        trials [
+        2 n 2 - [a,b] random a!
-            n 1- [1,b] random a!
+        a s n ^mod 1 = [
-            a s n ^mod 1 = [
+            f
-                0 count!
+        ] [
-                r [
+            r iota [
-                    2^ s * a swap n ^mod n - -1 =
+                2^ s * a swap n ^mod n - -1 =
-                    [ count 1+ count! r + ] when
+            ] any? not 
-                ] each
+        ] if
-                count zero? [ f prime?! trials + ] when
+    ] any? not ;
-            ] unless drop
-        ] each prime? ] ;
 
 PRIVATE>
 
-: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
-
 : miller-rabin* ( n numtrials -- ? )
     over {
         { [ dup 1 <= ] [ 3drop f ] }
@@ -42,11 +45,21 @@ PRIVATE>
 
 : miller-rabin ( n -- ? ) 10 miller-rabin* ;
 
+ERROR: prime-range-error n ;
+
 : next-prime ( n -- p )
-    next-odd dup miller-rabin [ next-prime ] unless ;
+    dup 1 < [ prime-range-error ] when
+    dup 1 = [
+        drop 2
+    ] [
+        next-odd dup miller-rabin [ next-prime ] unless
+    ] if ;
+
+: random-bits* ( numbits -- n )
+    1 - [ random-bits ] keep set-bit ;
 
 : random-prime ( numbits -- p )
-    random-bits next-prime ;
+    random-bits* next-prime ;
 
 ERROR: no-relative-prime n ;
 
@@ -74,3 +87,30 @@ ERROR: too-few-primes ;
     dup 5 < [ too-few-primes ] when
     2dup [ random-prime ] curry replicate
     dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
+
+! Safe primes are of the form p = 2q + 1, p,q are prime
+! See http://en.wikipedia.org/wiki/Safe_prime
+
+<PRIVATE
+
+: safe-prime-candidate? ( n -- ? )
+    1 + 6 divisor? ;
+
+: next-safe-prime-candidate ( n -- candidate )
+    next-prime dup safe-prime-candidate?
+    [ next-safe-prime-candidate ] unless ;
+
+PRIVATE>
+
+: safe-prime? ( q -- ? )
+    {
+        [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
+        [ miller-rabin ]
+    } 1&& ;
+
+: next-safe-prime ( n -- q )
+    next-safe-prime-candidate
+    dup safe-prime? [ next-safe-prime ] unless ;
+
+: random-safe-prime ( numbits -- p )
+    random-bits* next-safe-prime ;

basis/math/polynomials/polynomials.factor

@@ -16,7 +16,7 @@ IN: math.polynomials
 PRIVATE>
 
 : powers ( n x -- seq )
-    <array> 1 [ * ] accumulate nip ;
+    <repetition> 1 [ * ] accumulate nip ;
 
 : p= ( p q -- ? ) pextend = ;
 
@@ -29,7 +29,7 @@ PRIVATE>
 : n*p ( n p -- n*p ) n*v ;
 
 : pextend-conv ( p q -- p q )
-    2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
+    2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
 
 : p* ( p q -- r )
     2unempty pextend-conv <reversed> dup length
@@ -44,7 +44,7 @@ PRIVATE>
     2ptrim
     2dup [ length ] bi@ -
     dup 1 < [ drop 1 ] when
-    [ over length + 0 pad-head pextend ] keep 1+ ;
+    [ over length + 0 pad-head pextend ] keep 1 + ;
 
 : /-last ( seq seq -- a )
     #! divide the last two numbers in the sequences

basis/math/ranges/ranges.factor

@@ -10,7 +10,7 @@ TUPLE: range
 { step read-only } ;
 
 : <range> ( a b step -- range )
-    [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
+    [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
 
 M: range length ( seq -- n )
     length>> ;

basis/math/statistics/statistics.factor

@@ -15,7 +15,7 @@ IN: math.statistics
 
 : median ( seq -- n )
     natural-sort dup length even? [
-        [ midpoint@ dup 1- 2array ] keep nths mean
+        [ midpoint@ dup 1 - 2array ] keep nths mean
     ] [
         [ midpoint@ ] keep nth
     ] if ;
@@ -33,7 +33,7 @@ IN: math.statistics
         drop 0
     ] [
         [ [ mean ] keep [ - sq ] with sigma ] keep
-        length 1- /
+        length 1 - /
     ] if ;
 
 : std ( seq -- x )
@@ -47,7 +47,7 @@ IN: math.statistics
     0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
 
 : (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
-    * recip [ [ ((r)) ] keep length 1- / ] dip * ;
+    * recip [ [ ((r)) ] keep length 1 - / ] dip * ;
 
 : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
     first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;

basis/math/vectors/vectors-tests.factor

@@ -9,3 +9,8 @@ USING: math.vectors tools.test ;
 [ 5 ] [ { 1 2 } norm-sq ] unit-test
 [ 13 ] [ { 2 3 } norm-sq ] unit-test
 
+[ { 1.0  2.5  } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test 
+[ { 2.5  1.0  } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test 
+[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test 
+
+[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test 

basis/math/vectors/vectors.factor

@@ -6,6 +6,11 @@ IN: math.vectors
 
 : vneg ( u -- v ) [ neg ] map ;
 
+: v+n ( u n -- v ) [ + ] curry map ;
+: n+v ( n u -- v ) [ + ] with map ;
+: v-n ( u n -- v ) [ - ] curry map ;
+: n-v ( n u -- v ) [ - ] with map ;
+
 : v*n ( u n -- v ) [ * ] curry map ;
 : n*v ( n u -- v ) [ * ] with map ;
 : v/n ( u n -- v ) [ / ] curry map ;
@@ -19,6 +24,10 @@ IN: math.vectors
 : vmax ( u v -- w ) [ max ] 2map ;
 : vmin ( u v -- w ) [ min ] 2map ;
 
+: vfloor    ( v -- _v_ ) [ floor    ] map ;
+: vceiling  ( v -- ^v^ ) [ ceiling  ] map ;
+: vtruncate ( v -- -v- ) [ truncate ] map ;
+
 : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; 
 : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; 
 
@@ -32,6 +41,12 @@ IN: math.vectors
 : set-axis ( u v axis -- w )
     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
 
+: vlerp ( a b t -- a_t )
+    [ lerp ] 3map ;
+
+: vnlerp ( a b t -- a_t )
+    [ lerp ] curry 2map ;
+
 HINTS: vneg { array } ;
 HINTS: norm-sq { array } ;
 HINTS: norm { array } ;
@@ -50,3 +65,6 @@ HINTS: v/ { array array } ;
 HINTS: vmax { array array } ;
 HINTS: vmin { array array } ;
 HINTS: v. { array array } ;
+
+HINTS: vlerp { array array array } ;
+HINTS: vnlerp { array array object } ;

basis/random/random.factor

@@ -3,7 +3,7 @@
 USING: alien.c-types kernel math namespaces sequences
 io.backend io.binary combinators system vocabs.loader
 summary math.bitwise byte-vectors fry byte-arrays
-math.ranges ;
+math.ranges math.constants math.functions accessors ;
 IN: random
 
 SYMBOL: system-random-generator
@@ -69,6 +69,20 @@ PRIVATE>
 : with-secure-random ( quot -- )
     secure-random-generator get swap with-random ; inline
 
+: uniform-random-float ( min max -- n )
+    4 random-bytes underlying>> *uint >float
+    4 random-bytes underlying>> *uint >float
+    2.0 32 ^ * +
+    [ over - 2.0 -64 ^ * ] dip
+    * + ; inline
+
+: normal-random-float ( mean sigma -- n )
+    0.0 1.0 uniform-random-float
+    0.0 1.0 uniform-random-float
+    [ 2 pi * * cos ]
+    [ 1.0 swap - log -2.0 * sqrt ]
+    bi* * * + ;
+
 USE: vocabs.loader
 
 {

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -2,7 +2,7 @@ IN: specialized-arrays.tests
 USING: tools.test specialized-arrays sequences
 specialized-arrays.int specialized-arrays.bool
 specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int arrays ;
+specialized-arrays.direct.int specialized-arrays.char arrays ;
 
 [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
 
@@ -10,7 +10,7 @@ specialized-arrays.direct.int arrays ;
 
 [ 2 ] [ int-array{ 1 2 3 } second ] unit-test
 
-[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test
+[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
 
 [ ushort-array{ 1234 } ] [
     little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array

basis/tools/disassembler/udis/udis-tests.factor

@@ -0,0 +1,9 @@
+IN: tools.disassembler.udis.tests
+USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
+
+{
+    { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+    { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] }
+    { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+    [ ]
+} cond

basis/tools/disassembler/udis/udis.factor

@@ -16,7 +16,57 @@ IN: tools.disassembler.udis
 
 LIBRARY: libudis86
 
-TYPEDEF: char[592] ud
+C-STRUCT: ud_operand
+    { "int" "type" }
+    { "uchar" "size" }
+    { "ulonglong" "lval" }
+    { "int" "base" }
+    { "int" "index" }
+    { "uchar" "offset" }
+    { "uchar" "scale" } ;
+
+C-STRUCT: ud
+    { "void*" "inp_hook" }
+    { "uchar" "inp_curr" }
+    { "uchar" "inp_fill" }
+    { "FILE*" "inp_file" }
+    { "uchar" "inp_ctr" }
+    { "uchar*" "inp_buff" }
+    { "uchar*" "inp_buff_end" }
+    { "uchar" "inp_end" }
+    { "void*" "translator" }
+    { "ulonglong" "insn_offset" }
+    { "char[32]" "insn_hexcode" }
+    { "char[64]" "insn_buffer" }
+    { "uint" "insn_fill" }
+    { "uchar" "dis_mode" }
+    { "ulonglong" "pc" }
+    { "uchar" "vendor" }
+    { "struct map_entry*" "mapen" }
+    { "int" "mnemonic" }
+    { "ud_operand[3]" "operand" }
+    { "uchar" "error" }
+    { "uchar" "pfx_rex" }
+    { "uchar" "pfx_seg" }
+    { "uchar" "pfx_opr" }
+    { "uchar" "pfx_adr" }
+    { "uchar" "pfx_lock" }
+    { "uchar" "pfx_rep" }
+    { "uchar" "pfx_repe" }
+    { "uchar" "pfx_repne" }
+    { "uchar" "pfx_insn" }
+    { "uchar" "default64" }
+    { "uchar" "opr_mode" }
+    { "uchar" "adr_mode" }
+    { "uchar" "br_far" }
+    { "uchar" "br_near" }
+    { "uchar" "implicit_addr" }
+    { "uchar" "c1" }
+    { "uchar" "c2" }
+    { "uchar" "c3" }
+    { "uchar[256]" "inp_cache" }
+    { "uchar[64]" "inp_sess" }
+    { "ud_itab_entry*" "itab_entry" } ;
 
 FUNCTION: void ud_translate_intel ( ud* u ) ;
 FUNCTION: void ud_translate_att ( ud* u ) ;

basis/tools/time/time.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.vectors memory io io.styles prettyprint
+USING: kernel math memory io io.styles prettyprint
 namespaces system sequences splitting grouping assocs strings
 generic.single combinators ;
 IN: tools.time

basis/tools/trace/trace-tests.factor

@@ -1,4 +1,30 @@
 IN: tools.trace.tests
-USING: tools.trace tools.test sequences ;
+USING: tools.trace tools.test tools.continuations kernel math combinators
+sequences ;
 
-[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
+
+GENERIC: method-breakpoint-test ( x -- y )
+
+TUPLE: method-breakpoint-tuple ;
+
+M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
+
+\ method-breakpoint-test don't-step-into
+
+[ 3 ]
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test
+
+: case-breakpoint-test ( -- x )
+    5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test
+
+: call(-breakpoint-test ( -- x )
+    [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test

basis/tools/trace/trace.factor

@@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel
 sequences concurrency.messaging locals continuations threads
 namespaces namespaces.private make assocs accessors io strings
 prettyprint math math.parser words effects summary io.styles classes
-generic.math combinators.short-circuit ;
+generic.math combinators.short-circuit kernel.private quotations ;
 IN: tools.trace
 
-: callstack-depth ( callstack -- n )
-    callstack>array length 2/ ;
-
-SYMBOL: end
-
 SYMBOL: exclude-vocabs
 SYMBOL: include-vocabs
 
 exclude-vocabs { "math" "accessors" } swap set-global
 
+<PRIVATE
+
+: callstack-depth ( callstack -- n )
+    callstack>array length 2/ ;
+
+SYMBOL: end
+
 : include? ( vocab -- ? )
     include-vocabs get dup [ member? ] [ 2drop t ] if ;
 
@@ -65,15 +67,20 @@ M: trace-step summary
     [ CHAR: \s <string> write ]
     [ number>string write ": " write ] bi ;
 
+: trace-into? ( continuation -- ? )
+    continuation-current into? ;
+
 : trace-step ( continuation -- continuation' )
-    dup continuation-current end eq? [
+    dup call>> innermost-frame-executing quotation? [
-        [ print-depth ]
+        dup continuation-current end eq? [
-        [ print-step ]
+            [ print-depth ]
-        [
+            [ print-step ]
-            dup continuation-current into?
+            [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
-            [ continuation-step-into ] [ continuation-step ] if
+            tri
-        ] tri
+        ] unless
-    ] unless ;
+    ] when ;
+
+PRIVATE>
 
 : trace ( quot -- data )
     [ [ trace-step ] break-hook ] dip

basis/ui/ui.factor

@@ -145,7 +145,9 @@ SYMBOL: ui-thread
 PRIVATE>
 
 : find-window ( quot -- world )
-    [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
+    [ windows get values ] dip
+    '[ dup children>> [ ] [ nip first ] if-empty @ ]
+    find-last nip ; inline
 
 : ui-running? ( -- ? )
     \ ui-running get-global ;

basis/windows/dinput/dinput.factor

@@ -444,6 +444,18 @@ CONSTANT: DISCL_FOREGROUND    HEX: 00000004
 CONSTANT: DISCL_BACKGROUND    HEX: 00000008
 CONSTANT: DISCL_NOWINKEY      HEX: 00000010
 
+CONSTANT: DIMOFS_X        0
+CONSTANT: DIMOFS_Y        4
+CONSTANT: DIMOFS_Z        8
+CONSTANT: DIMOFS_BUTTON0 12
+CONSTANT: DIMOFS_BUTTON1 13
+CONSTANT: DIMOFS_BUTTON2 14
+CONSTANT: DIMOFS_BUTTON3 15
+CONSTANT: DIMOFS_BUTTON4 16
+CONSTANT: DIMOFS_BUTTON5 17
+CONSTANT: DIMOFS_BUTTON6 18
+CONSTANT: DIMOFS_BUTTON7 19
+
 CONSTANT: DIK_ESCAPE          HEX: 01
 CONSTANT: DIK_1               HEX: 02
 CONSTANT: DIK_2               HEX: 03

core/alien/strings/strings.factor

@@ -40,19 +40,26 @@ M: unix alien>native-string utf8 alien>string ;
 
 HOOK: native-string>alien os ( string -- alien )
 
-M: wince native-string>alien utf16n string>alien ;
+M: windows native-string>alien utf16n string>alien ;
-
-M: winnt native-string>alien utf8 string>alien ;
 
 M: unix native-string>alien utf8 string>alien ;
 
 : dll-path ( dll -- string )
     path>> alien>native-string ;
 
-: string>symbol ( str -- alien )
+HOOK: string>symbol* os ( str/seq -- alien )
-    dup string?
+
-    [ native-string>alien ]
+M: winnt string>symbol* utf8 string>alien ;
-    [ [ native-string>alien ] map ] if ;
+
+M: wince string>symbol* utf16n string>alien ;
+
+M: unix string>symbol* utf8 string>alien ;
+
+GENERIC: string>symbol ( str -- alien )
+
+M: string string>symbol string>symbol* ;
+
+M: sequence string>symbol [ string>symbol* ] map ;
 
 [
     8 getenv utf8 alien>string string>cpu \ cpu set-global

core/bootstrap/primitives.factor

@@ -231,7 +231,8 @@ bi
     "vocabulary"
     { "def" { "quotation" "quotations" } initial: [ ] }
     "props"
-    { "direct-entry-def" }
+    "pic-def"
+    "pic-tail-def"
     { "counter" { "fixnum" "math" } }
     { "sub-primitive" read-only }
 } define-builtin
@@ -505,6 +506,7 @@ tuple
     { "load-locals" "locals.backend" (( ... n -- )) }
     { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
     { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
+    { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
     { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
     { "lookup-method" "generic.single.private" (( object methods -- method )) }
     { "reset-dispatch-stats" "generic.single" (( -- )) }

core/continuations/continuations-tests.factor

@@ -64,7 +64,7 @@ IN: continuations.tests
 
 [ 1 2 ] [ bar ] unit-test
 
-[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
+[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
 
 [ 1 ] [ "c" get innermost-frame-scan ] unit-test
 

core/generic/hook/hook.factor

@@ -17,8 +17,6 @@ M: hook-combination picker
 
 M: hook-combination dispatch# drop 0 ;
 
-M: hook-combination inline-cache-quot 2drop f ;
-
 M: hook-combination mega-cache-quot
     1quotation picker [ lookup-method (execute) ] surround ;
 

core/generic/single/single-tests.factor

@@ -273,5 +273,5 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
 [ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
 [ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
 
-[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test
+[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
 [ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test

core/generic/single/single.factor

@@ -238,10 +238,14 @@ M: f compile-engine ;
         [ <engine> compile-engine ] bi
     ] tri ;
 
-HOOK: inline-cache-quot combination ( word methods -- quot/f )
+HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
+
+M: single-combination inline-cache-quots 2drop f f ;
 
 : define-inline-cache-quot ( word methods -- )
-    [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
+    [ drop ] [ inline-cache-quots ] 2bi
+    [ >>pic-def ] [ >>pic-tail-def ] bi*
+    drop ;
 
 HOOK: mega-cache-quot combination ( methods -- quot/f )
 

core/generic/standard/standard.factor

@@ -3,7 +3,7 @@
 USING: accessors definitions generic generic.single kernel
 namespaces words math math.order combinators sequences
 generic.single.private quotations kernel.private
-assocs arrays layouts ;
+assocs arrays layouts make ;
 IN: generic.standard
 
 TUPLE: standard-combination < single-combination # ;
@@ -38,17 +38,22 @@ M: standard-generic effective-method
     [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
     (effective-method) ;
 
-M: standard-combination inline-cache-quot ( word methods -- )
+: inline-cache-quot ( word methods miss-word -- quot )
+    [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
+
+M: standard-combination inline-cache-quots
     #! Direct calls to the generic word (not tail calls or indirect calls)
     #! will jump to the inline cache entry point instead of the megamorphic
     #! dispatch entry point.
-    combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
+    [ \ inline-cache-miss inline-cache-quot ]
+    [ \ inline-cache-miss-tail inline-cache-quot ]
+    2bi ;
 
 : make-empty-cache ( -- array )
     mega-cache-size get f <array> ;
 
 M: standard-combination mega-cache-quot
-    combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
+    combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
 
 M: standard-generic definer drop \ GENERIC# f ;
 

core/hashtables/hashtables.factor

@@ -139,14 +139,14 @@ M: hashtable set-at ( value key hash -- )
 PRIVATE>
 
 M: hashtable >alist
-    [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
+    [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
         [
             [
                 [ 1 fixnum-shift-fast ] dip
                 [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
             ] dip
             pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
-        ] 2curry each
+        ] 2curry each-integer
     ] keep { } like ;
 
 M: hashtable clone

core/io/io-docs.factor

@@ -117,6 +117,7 @@ HELP: seek-relative
 }
 { $description "Seeks to an offset from the current position of the stream pointer." } ;
 
+{ seek-absolute seek-relative seek-end } related-words
 
 HELP: seek-input
 { $values
@@ -343,6 +344,10 @@ $nl
 { $subsection bl }
 "Seeking on the default output stream:"
 { $subsection seek-output }
+"Seeking descriptors:"
+{ $subsection seek-absolute }
+{ $subsection seek-relative }
+{ $subsection seek-end }
 "A pair of combinators for rebinding the " { $link output-stream } " variable:"
 { $subsection with-output-stream }
 { $subsection with-output-stream* }

core/words/words.factor

@@ -155,7 +155,8 @@ M: word reset-word
     [ subwords forget-all ]
     [ reset-word ]
     [
-        f >>direct-entry-def
+        f >>pic-def
+        f >>pic-tail-def
         {
             "methods"
             "combination"

extra/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 ;

extra/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,11 +18,13 @@ 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." } ;
@@ -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"

extra/game-input/game-input.factor

@@ -73,6 +73,15 @@ M: keyboard-state clone
 
 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 ;
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
 {
     { [ os windows? ] [ "game-input.dinput" require ] }
     { [ os macosx? ] [ "game-input.iokit" require ] }

extra/game-input/iokit/iokit.factor

@@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
 sequences locals combinators.short-circuit threads
 namespaces assocs vectors arrays combinators
 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
@@ -23,9 +23,13 @@ iokit-game-input-backend game-input-backend set-global
 
 CONSTANT: game-devices-matching-seq
     {
+        H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
+        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 +50,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 } }
 
@@ -90,10 +96,17 @@ CONSTANT: hat-switch-matching-hash
 : transfer-element-property ( element from-key to-key -- )
     [ dupd element-property ] dip swap set-element-property ;
 
+: mouse-device? ( device -- ? )
+    {
+        [ 1 1 IOHIDDeviceConformsTo ]
+        [ 1 2 IOHIDDeviceConformsTo ]
+    } 1|| ;
+
 : controller-device? ( device -- ? )
     {
         [ 1 4 IOHIDDeviceConformsTo ]
         [ 1 5 IOHIDDeviceConformsTo ]
+        [ 1 8 IOHIDDeviceConformsTo ]
     } 1|| ;
 
 : element-usage ( element -- {usage-page,usage} )
@@ -118,6 +131,8 @@ CONSTANT: hat-switch-matching-hash
     { 1 HEX: 35 } = ; inline
 : slider? ( {usage-page,usage} -- ? )
     { 1 HEX: 36 } = ; inline
+: wheel? ( {usage-page,usage} -- ? )
+    { 1 HEX: 38 } = ; inline
 : hat-switch? ( {usage-page,usage} -- ? )
     { 1 HEX: 39 } = ; inline
 
@@ -132,12 +147,17 @@ 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 ( hid-value usage state -- )
+    [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
+
 : record-controller ( controller-state value -- )
     dup IOHIDValueGetElement element-usage {
-        { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] } 
+        { [ dup button? ] [ rot record-button ] } 
         { [ dup x-axis? ] [ drop axis-value >>x drop ] }
         { [ dup y-axis? ] [ drop axis-value >>y drop ] }
         { [ dup z-axis? ] [ drop axis-value >>z drop ] }
@@ -149,7 +169,7 @@ CONSTANT: pov-values
         [ 3drop ]
     } cond ;
 
-SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
 
 : ?set-nth ( value nth seq -- )
     2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
@@ -161,6 +181,27 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
         +keyboard-state+ get ?set-nth
     ] [ drop ] if ;
 
+: record-mouse ( value -- )
+    dup IOHIDValueGetElement element-usage {
+        { [ dup button? ] [ +mouse-state+ get record-button ] }
+        { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
+        { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
+        { [ dup wheel?  ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
+        { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
+        [ 2drop ]
+    } cond ;
+
+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 ]
     [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
@@ -194,12 +235,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 +259,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? ] [ value record-mouse ] }
+            [ 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)

extra/images/viewer/viewer.factor

@@ -5,23 +5,28 @@ opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
 ui.gadgets.panes ui.render ui.images ;
 IN: images.viewer
 
-TUPLE: image-gadget < gadget image-name ;
+TUPLE: image-gadget < gadget image texture ;
 
-M: image-gadget pref-dim*
+M: image-gadget pref-dim* image>> dim>> ;
-    image-name>> image-dim ;
+
+: image-gadget-texture ( gadget -- texture )
+    dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
 
 M: image-gadget draw-gadget* ( gadget -- )
-    image-name>> draw-image ;
+    [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
 
-: <image-gadget> ( image-name -- gadget )
+! Todo: delete texture on ungraft
+
+GENERIC: <image-gadget> ( object -- gadget )
+
+M: image <image-gadget>
     \ image-gadget new
-        swap >>image-name ;
+        swap >>image ;
 
-: image-window ( path -- gadget )
+M: string <image-gadget> load-image <image-gadget> ;
-    [ <image-name> <image-gadget> dup ] [ open-window ] bi ;
 
-GENERIC: image. ( object -- )
+M: pathname <image-gadget> load-image <image-gadget> ;
 
-M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image-window ( object -- ) <image-gadget> "Image" open-window ;
 
-M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image. ( object -- ) <image-gadget> gadget. ;

extra/noise/noise.factor

@@ -0,0 +1,121 @@
+USING: byte-arrays combinators fry images kernel locals math
+math.affine-transforms math.functions math.order
+math.polynomials math.vectors random random.mersenne-twister
+sequences sequences.product ;
+IN: noise
+
+: <perlin-noise-table> ( -- table )
+    256 iota >byte-array randomize dup append ;
+
+<PRIVATE
+
+: fade ( point -- point' )
+    { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
+
+:: grad ( hash gradients -- gradient )
+    hash 8  bitand zero? [ gradients first ] [ gradients second ] if
+        :> u
+    hash 12 bitand zero?
+    [ gradients second ]
+    [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if
+        :> v
+
+    hash 1 bitand zero? [ u ] [ u neg ] if
+    hash 2 bitand zero? [ v ] [ v neg ] if + ;
+
+: unit-cube ( point -- cube )
+    [ floor >fixnum 256 mod ] map ;
+
+:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb )
+    cube first  :> x
+    cube second :> y
+    cube third  :> z
+    x     table nth y + :> a
+    x 1 + table nth y + :> b
+
+    a     table nth z + :> aa
+    b     table nth z + :> ba
+    a 1 + table nth z + :> ab
+    b 1 + table nth z + :> bb
+
+    aa     table nth 
+    ba     table nth 
+    ab     table nth 
+    bb     table nth 
+    aa 1 + table nth 
+    ba 1 + table nth 
+    ab 1 + table nth 
+    bb 1 + table nth ;
+
+:: 2tetra@ ( p q r s t u v w quot -- )
+    p q quot call
+    r s quot call
+    t u quot call
+    v w quot call
+    ; inline
+
+: with-seed ( seed quot -- )
+    [ <mersenne-twister> ] dip with-random ; inline
+
+: >byte-map ( floats -- bytes )
+    [ 255.0 * >fixnum ] B{ } map-as ;
+
+: >image ( bytes dim -- image )
+    swap [ L f ] dip image boa ;
+
+PRIVATE>
+
+:: perlin-noise ( table point -- value )
+    point unit-cube :> cube
+    point dup vfloor v- :> gradients
+    gradients fade :> faded
+
+    table cube hashes {
+        [ gradients                       grad ]
+        [ gradients { -1.0  0.0  0.0 } v+ grad ]
+        [ gradients {  0.0 -1.0  0.0 } v+ grad ]
+        [ gradients { -1.0 -1.0  0.0 } v+ grad ]
+        [ gradients {  0.0  0.0 -1.0 } v+ grad ]
+        [ gradients { -1.0  0.0 -1.0 } v+ grad ]
+        [ gradients {  0.0 -1.0 -1.0 } v+ grad ]
+        [ gradients { -1.0 -1.0 -1.0 } v+ grad ]
+    } spread
+    [ faded first lerp ] 2tetra@
+    [ faded second lerp ] 2bi@
+    faded third lerp ;
+
+: normalize-0-1 ( sequence -- sequence' )
+    [ supremum ] [ infimum [ - ] keep ] [ ] tri
+    [ swap - ] with map [ swap / ] with map ;
+
+: clamp-0-1 ( sequence -- sequence' )
+    [ 0.0 max 1.0 min ] map ;
+
+: perlin-noise-map ( table transform dim -- map ) 
+    [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ;
+
+: perlin-noise-byte-map ( table transform dim -- map )
+    perlin-noise-map normalize-0-1 >byte-map ;
+
+: perlin-noise-image ( table transform dim -- image )
+    [ perlin-noise-byte-map ] [ >image ] bi ;
+
+: uniform-noise-map ( seed dim -- map )
+    [ product [ 0.0 1.0 uniform-random-float ] replicate ]
+    curry with-seed ;
+
+: uniform-noise-byte-map ( seed dim -- map )
+    uniform-noise-map >byte-map ;
+
+: uniform-noise-image ( seed dim -- image )
+    [ uniform-noise-byte-map ] [ >image ] bi ;
+
+: normal-noise-map ( seed sigma dim -- map )
+    swap '[ _ product [ 0.5 _ normal-random-float ] replicate ]
+    with-seed ;
+
+: normal-noise-byte-map ( seed sigma dim -- map )
+    normal-noise-map clamp-0-1 >byte-map ;
+
+: normal-noise-image ( seed sigma dim -- image )
+    [ normal-noise-byte-map ] [ >image ] bi ;

vm/Config.windows

@@ -6,5 +6,5 @@ EXE_EXTENSION=.exe
 CONSOLE_EXTENSION=.com
 DLL_EXTENSION=.dll
 SHARED_DLL_EXTENSION=.dll
-LINKER = $(CC) -shared -mno-cygwin -o 
+LINKER = $(CPP) -shared -mno-cygwin -o 
 LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)

vm/alien.cpp

@@ -77,7 +77,7 @@ PRIMITIVE(alien_address)
 }
 
 /* pop ( alien n ) from datastack, return alien's address plus n */
-static void *alien_pointer(void)
+static void *alien_pointer()
 {
 	fixnum offset = to_fixnum(dpop());
 	return unbox_alien() + offset;
@@ -128,7 +128,7 @@ PRIMITIVE(dlsym)
 	gc_root<byte_array> name(dpop());
 	name.untag_check();
 
-	vm_char *sym = (vm_char *)(name.untagged() + 1);
+	symbol_char *sym = name->data<symbol_char>();
 
 	if(library.value() == F)
 		box_alien(ffi_dlsym(NULL,sym));
@@ -182,7 +182,7 @@ VM_C_API char *alien_offset(cell obj)
 }
 
 /* pop an object representing a C pointer */
-VM_C_API char *unbox_alien(void)
+VM_C_API char *unbox_alien()
 {
 	return alien_offset(dpop());
 }

vm/alien.hpp

@@ -39,7 +39,7 @@ PRIMITIVE(dlclose);
 PRIMITIVE(dll_validp);
 
 VM_C_API char *alien_offset(cell object);
-VM_C_API char *unbox_alien(void);
+VM_C_API char *unbox_alien();
 VM_C_API void box_alien(void *ptr);
 VM_C_API void to_value_struct(cell src, void *dest, cell size);
 VM_C_API void box_value_struct(void *src, cell size);

vm/callstack.cpp

@@ -54,7 +54,7 @@ This means that if 'callstack' is called in tail position, we
 will have popped a necessary frame... however this word is only
 called by continuation implementation, and user code shouldn't
 be calling it at all, so we leave it as it is for now. */
-stack_frame *capture_start(void)
+stack_frame *capture_start()
 {
 	stack_frame *frame = stack_chain->callstack_bottom - 1;
 	while(frame >= stack_chain->callstack_top

vm/code_block.cpp

@@ -8,6 +8,159 @@ void flush_icache_for(code_block *block)
 	flush_icache((cell)block,block->size);
 }
 
+static int number_of_parameters(relocation_type type)
+{
+	switch(type)
+	{
+	case RT_PRIMITIVE:
+	case RT_XT:
+	case RT_XT_PIC:
+	case RT_XT_PIC_TAIL:
+	case RT_IMMEDIATE:
+	case RT_HERE:
+	case RT_UNTAGGED:
+		return 1;
+	case RT_DLSYM:
+		return 2;
+	case RT_THIS:
+	case RT_STACK_CHAIN:
+	case RT_MEGAMORPHIC_CACHE_HITS:
+		return 0;
+	default:
+		critical_error("Bad rel type",type);
+		return -1; /* Can't happen */
+	}
+}
+
+void *object_xt(cell obj)
+{
+	switch(tagged<object>(obj).type())
+	{
+	case WORD_TYPE:
+		return untag<word>(obj)->xt;
+	case QUOTATION_TYPE:
+		return untag<quotation>(obj)->xt;
+	default:
+		critical_error("Expected word or quotation",obj);
+		return NULL;
+	}
+}
+
+static void *xt_pic(word *w, cell tagged_quot)
+{
+	if(tagged_quot == F || max_pic_size == 0)
+		return w->xt;
+	else
+	{
+		quotation *quot = untag<quotation>(tagged_quot);
+		if(quot->compiledp == F)
+			return w->xt;
+		else
+			return quot->xt;
+	}
+}
+
+void *word_xt_pic(word *w)
+{
+	return xt_pic(w,w->pic_def);
+}
+
+void *word_xt_pic_tail(word *w)
+{
+	return xt_pic(w,w->pic_tail_def);
+}
+
+/* References to undefined symbols are patched up to call this function on
+image load */
+void undefined_symbol()
+{
+	general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
+}
+
+/* Look up an external library symbol referenced by a compiled code block */
+void *get_rel_symbol(array *literals, cell index)
+{
+	cell symbol = array_nth(literals,index);
+	cell library = array_nth(literals,index + 1);
+
+	dll *d = (library == F ? NULL : untag<dll>(library));
+
+	if(d != NULL && !d->dll)
+		return (void *)undefined_symbol;
+
+	switch(tagged<object>(symbol).type())
+	{
+	case BYTE_ARRAY_TYPE:
+		{
+			symbol_char *name = alien_offset(symbol);
+			void *sym = ffi_dlsym(d,name);
+
+			if(sym)
+				return sym;
+			else
+			{
+				return (void *)undefined_symbol;
+			}
+		}
+	case ARRAY_TYPE:
+		{
+			cell i;
+			array *names = untag<array>(symbol);
+			for(i = 0; i < array_capacity(names); i++)
+			{
+				symbol_char *name = alien_offset(array_nth(names,i));
+				void *sym = ffi_dlsym(d,name);
+
+				if(sym)
+					return sym;
+			}
+			return (void *)undefined_symbol;
+		}
+	default:
+		critical_error("Bad symbol specifier",symbol);
+		return (void *)undefined_symbol;
+	}
+}
+
+cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+{
+	array *literals = untag<array>(compiled->literals);
+	cell offset = REL_OFFSET(rel) + (cell)compiled->xt();
+
+#define ARG array_nth(literals,index)
+
+	switch(REL_TYPE(rel))
+	{
+	case RT_PRIMITIVE:
+		return (cell)primitives[untag_fixnum(ARG)];
+	case RT_DLSYM:
+		return (cell)get_rel_symbol(literals,index);
+	case RT_IMMEDIATE:
+		return ARG;
+	case RT_XT:
+		return (cell)object_xt(ARG);
+	case RT_XT_PIC:
+		return (cell)word_xt_pic(untag<word>(ARG));
+	case RT_XT_PIC_TAIL:
+		return (cell)word_xt_pic_tail(untag<word>(ARG));
+	case RT_HERE:
+		return offset + (short)untag_fixnum(ARG);
+	case RT_THIS:
+		return (cell)(compiled + 1);
+	case RT_STACK_CHAIN:
+		return (cell)&stack_chain;
+	case RT_UNTAGGED:
+		return untag_fixnum(ARG);
+	case RT_MEGAMORPHIC_CACHE_HITS:
+		return (cell)&megamorphic_cache_hits;
+	default:
+		critical_error("Bad rel type",rel);
+		return 0; /* Can't happen */
+	}
+
+#undef ARG
+}
+
 void iterate_relocations(code_block *compiled, relocation_iterator iter)
 {
 	if(compiled->relocation != F)
@@ -20,29 +173,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
 		for(cell i = 0; i < length; i++)
 		{
 			relocation_entry rel = relocation->data<relocation_entry>()[i];
-
 			iter(rel,index,compiled);
-
+			index += number_of_parameters(REL_TYPE(rel));			
-			switch(REL_TYPE(rel))
-			{
-			case RT_PRIMITIVE:
-			case RT_XT:
-			case RT_XT_DIRECT:
-			case RT_IMMEDIATE:
-			case RT_HERE:
-			case RT_UNTAGGED:
-				index++;
-				break;
-			case RT_DLSYM:
-				index += 2;
-				break;
-			case RT_THIS:
-			case RT_STACK_CHAIN:
-				break;
-			default:
-				critical_error("Bad rel type",rel);
-				return; /* Can't happen */
-			}
 		}
 	}
 }
@@ -84,6 +216,9 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
 	case RC_ABSOLUTE_PPC_2_2:
 		store_address_2_2((cell *)offset,absolute_value);
 		break;
+	case RC_ABSOLUTE_PPC_2:
+		store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
+		break;
 	case RC_RELATIVE_PPC_2:
 		store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
 		break;
@@ -154,52 +289,24 @@ void copy_literal_references(code_block *compiled)
 	}
 }
 
-void *object_xt(cell obj)
+/* Compute an address to store at a relocation */
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
 {
-	switch(tagged<object>(obj).type())
+#ifdef FACTOR_DEBUG
-	{
+	tagged<array>(compiled->literals).untag_check();
-	case WORD_TYPE:
+	tagged<byte_array>(compiled->relocation).untag_check();
-		return untag<word>(obj)->xt;
+#endif
-	case QUOTATION_TYPE:
-		return untag<quotation>(obj)->xt;
-	default:
-		critical_error("Expected word or quotation",obj);
-		return NULL;
-	}
-}
 
-void *word_direct_xt(word *w)
+	store_address_in_code_block(REL_CLASS(rel),
-{
+				    REL_OFFSET(rel) + (cell)compiled->xt(),
-	cell tagged_quot = w->direct_entry_def;
+				    compute_relocation(rel,index,compiled));
-	if(tagged_quot == F || max_pic_size == 0)
-		return w->xt;
-	else
-	{
-		quotation *quot = untag<quotation>(tagged_quot);
-		if(quot->compiledp == F)
-			return w->xt;
-		else
-			return quot->xt;
-	}
 }
 
 void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
 {
 	relocation_type type = REL_TYPE(rel);
-	if(type == RT_XT || type == RT_XT_DIRECT)
+	if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
-	{
+		relocate_code_block_step(rel,index,compiled);
-		cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
-		array *literals = untag<array>(compiled->literals);
-		cell obj = array_nth(literals,index);
-
-		void *xt;
-		if(type == RT_XT)
-			xt = object_xt(obj);
-		else
-			xt = word_direct_xt(untag<word>(obj));
-
-		store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt);
-	}
 }
 
 /* Relocate new code blocks completely; updating references to literals,
@@ -300,108 +407,6 @@ void mark_object_code_block(object *object)
 	}
 }
 
-/* References to undefined symbols are patched up to call this function on
-image load */
-void undefined_symbol(void)
-{
-	general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
-}
-
-/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(array *literals, cell index)
-{
-	cell symbol = array_nth(literals,index);
-	cell library = array_nth(literals,index + 1);
-
-	dll *d = (library == F ? NULL : untag<dll>(library));
-
-	if(d != NULL && !d->dll)
-		return (void *)undefined_symbol;
-
-	switch(tagged<object>(symbol).type())
-	{
-	case BYTE_ARRAY_TYPE:
-		{
-			symbol_char *name = alien_offset(symbol);
-			void *sym = ffi_dlsym(d,name);
-
-			if(sym)
-				return sym;
-			else
-			{
-				printf("%s\n",name);
-				return (void *)undefined_symbol;
-			}
-		}
-	case ARRAY_TYPE:
-		{
-			cell i;
-			array *names = untag<array>(symbol);
-			for(i = 0; i < array_capacity(names); i++)
-			{
-				symbol_char *name = alien_offset(array_nth(names,i));
-				void *sym = ffi_dlsym(d,name);
-
-				if(sym)
-					return sym;
-			}
-			return (void *)undefined_symbol;
-		}
-	default:
-		critical_error("Bad symbol specifier",symbol);
-		return (void *)undefined_symbol;
-	}
-}
-
-/* Compute an address to store at a relocation */
-void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
-{
-#ifdef FACTOR_DEBUG
-	tagged<array>(compiled->literals).untag_check();
-	tagged<byte_array>(compiled->relocation).untag_check();
-#endif
-
-	cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
-	array *literals = untag<array>(compiled->literals);
-	fixnum absolute_value;
-
-	switch(REL_TYPE(rel))
-	{
-	case RT_PRIMITIVE:
-		absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))];
-		break;
-	case RT_DLSYM:
-		absolute_value = (cell)get_rel_symbol(literals,index);
-		break;
-	case RT_IMMEDIATE:
-		absolute_value = array_nth(literals,index);
-		break;
-	case RT_XT:
-		absolute_value = (cell)object_xt(array_nth(literals,index));
-		break;
-	case RT_XT_DIRECT:
-		absolute_value = (cell)word_direct_xt(untag<word>(array_nth(literals,index)));
-		break;
-	case RT_HERE:
-		absolute_value = offset + (short)untag_fixnum(array_nth(literals,index));
-		break;
-	case RT_THIS:
-		absolute_value = (cell)(compiled + 1);
-		break;
-	case RT_STACK_CHAIN:
-		absolute_value = (cell)&stack_chain;
-		break;
-	case RT_UNTAGGED:
-		absolute_value = untag_fixnum(array_nth(literals,index));
-		break;
-	default:
-		critical_error("Bad rel type",rel);
-		return; /* Can't happen */
-	}
-
-	store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
-}
-
 /* Perform all fixups on a code block */
 void relocate_code_block(code_block *compiled)
 {

vm/code_block.hpp

@@ -8,10 +8,12 @@ enum relocation_type {
 	RT_DLSYM,
 	/* a pointer to a compiled word reference */
 	RT_DISPATCH,
-	/* a word's general entry point XT */
+	/* a word or quotation's general entry point */
 	RT_XT,
-	/* a word's direct entry point XT */
+	/* a word's PIC entry point */
-	RT_XT_DIRECT,
+	RT_XT_PIC,
+	/* a word's tail-call PIC entry point */
+	RT_XT_PIC_TAIL,
 	/* current offset */
 	RT_HERE,
 	/* current code block */
@@ -22,6 +24,8 @@ enum relocation_type {
 	RT_STACK_CHAIN,
 	/* untagged fixnum literal */
 	RT_UNTAGGED,
+	/* address of megamorphic_cache_hits var */
+	RT_MEGAMORPHIC_CACHE_HITS,
 };
 
 enum relocation_class {
@@ -31,8 +35,10 @@ enum relocation_class {
 	RC_ABSOLUTE,
 	/* relative address in a 32-bit location */
 	RC_RELATIVE,
-	/* relative address in a PowerPC LIS/ORI sequence */
+	/* absolute address in a PowerPC LIS/ORI sequence */
 	RC_ABSOLUTE_PPC_2_2,
+	/* absolute address in a PowerPC LWZ instruction */
+	RC_ABSOLUTE_PPC_2,
 	/* relative address in a PowerPC LWZ/STW/BC instruction */
 	RC_RELATIVE_PPC_2,
 	/* relative address in a PowerPC B/BL instruction */
@@ -45,6 +51,7 @@ enum relocation_class {
 	RC_INDIRECT_ARM_PC
 };
 
+#define REL_ABSOLUTE_PPC_2_MASK 0xffff
 #define REL_RELATIVE_PPC_2_MASK 0xfffc
 #define REL_RELATIVE_PPC_3_MASK 0x3fffffc
 #define REL_INDIRECT_ARM_MASK 0xfff
@@ -82,7 +89,7 @@ void mark_object_code_block(object *scan);
 
 void relocate_code_block(code_block *relocating);
 
-inline static bool stack_traces_p(void)
+inline static bool stack_traces_p()
 {
 	return userenv[STACK_TRACES_ENV] != F;
 }

vm/code_gc.cpp

@@ -303,7 +303,7 @@ cell heap_size(heap *heap)
 }
 
 /* Compute where each block is going to go, after compaction */
-	cell compute_heap_forwarding(heap *heap, std::tr1::unordered_map<heap_block *,char *> &forwarding)
+cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
 {
 	heap_block *scan = first_block(heap);
 	char *address = (char *)first_block(heap);
@@ -324,7 +324,7 @@ cell heap_size(heap *heap)
 	return (cell)address - heap->seg->start;
 }
 
-	void compact_heap(heap *heap, std::tr1::unordered_map<heap_block *,char *> &forwarding)
+void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
 {
 	heap_block *scan = first_block(heap);