Merge branch 'master' of git://factorcode.org/git/factor

basis/bootstrap/image/image.factor

@@ -38,11 +38,11 @@ IN: bootstrap.image
 
 ! Object cache; we only consider numbers equal if they have the
 ! same type
-TUPLE: id obj ;
+TUPLE: eql-wrapper obj ;
 
-C: <id> id
+C: <eql-wrapper> eql-wrapper
 
-M: id hashcode* obj>> hashcode* ;
+M: eql-wrapper hashcode* obj>> hashcode* ;
 
 GENERIC: (eql?) ( obj1 obj2 -- ? )
 
@@ -62,19 +62,27 @@ M: sequence (eql?)
 
 M: object (eql?) = ;
 
-M: id equal?
+M: eql-wrapper equal?
-    over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+    over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+TUPLE: eq-wrapper obj ;
+
+C: <eq-wrapper> eq-wrapper
+
+M: eq-wrapper equal?
+    over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
 
 SYMBOL: objects
 
-: (objects) ( obj -- id assoc ) <id> objects get ; inline
+: cache-eql-object ( obj quot -- value )
+    [ <eql-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
 
-: lookup-object ( obj -- n/f ) (objects) at ;
+: cache-eq-object ( obj quot -- value )
+    [ <eq-wrapper> objects get ] dip '[ obj>> @ ] cache ; inline
 
-: put-object ( n obj -- ) (objects) set-at ;
+: lookup-object ( obj -- n/f ) <eq-wrapper> objects get at ;
 
-: cache-object ( obj quot -- value )
+: put-object ( n obj -- ) <eq-wrapper> objects get set-at ;
-    [ (objects) ] dip '[ obj>> @ ] cache ; inline
 
 ! Constants
 
@@ -252,7 +260,7 @@ GENERIC: ' ( obj -- ptr )
 M: bignum '
     [
         bignum [ emit-bignum ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Fixnums
 
@@ -277,7 +285,7 @@ M: float '
         float [
             align-here double>bits emit-64
         ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Special objects
 
@@ -340,7 +348,7 @@ M: word ' ;
 ! Wrappers
 
 M: wrapper '
-    wrapped>> ' wrapper [ emit ] emit-object ;
+    [ wrapped>> ' wrapper [ emit ] emit-object ] cache-eql-object ;
 
 ! Strings
 : native> ( object -- object )
@@ -379,7 +387,7 @@ M: wrapper '
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    [ emit-string ] cache-object ;
+    [ emit-string ] cache-eql-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -390,10 +398,12 @@ M: string '
     ] bi* ;
 
 M: byte-array '
+    [
         byte-array [
             dup length emit-fixnum
             pad-bytes emit-bytes
-    ] emit-object ;
+        ] emit-object
+    ] cache-eq-object ;
 
 ! Tuples
 ERROR: tuple-removed class ;
@@ -408,20 +418,22 @@ ERROR: tuple-removed class ;
 
 : emit-tuple ( tuple -- pointer )
     dup class name>> "tombstone" =
-    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-eql-object ]
+    [ [ (emit-tuple) ] cache-eq-object ]
+    if ;
 
 M: tuple ' emit-tuple ;
 
 M: tombstone '
     state>> "((tombstone))" "((empty))" ?
     "hashtables.private" lookup def>> first
-    [ emit-tuple ] cache-object ;
+    [ emit-tuple ] cache-eql-object ;
 
 ! Arrays
 : emit-array ( array -- offset )
     [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
-M: array ' emit-array ;
+M: array ' [ emit-array ] cache-eq-object ;
 
 ! This is a hack. We need to detect arrays which are tuple
 ! layout arrays so that they can be internalized, but making
@@ -438,7 +450,7 @@ M: tuple-layout-array '
     [
         [ dup integer? [ <fake-bignum> ] when ] map
         emit-array
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! Quotations
 
@@ -452,7 +464,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache-object ;
+    ] cache-eql-object ;
 
 ! End of the image
 

basis/compiler/cfg/builder/builder-tests.factor

@@ -180,3 +180,8 @@ IN: compiler.cfg.builder.tests
     [ { byte-array fixnum } declare set-alien-unsigned-1 ]
     [ ##set-alien-integer-1? ] contains-insn?
 ] unit-test
+
+[ f ] [
+    [ 1000 [ ] times ]
+    [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
+] unit-test

basis/cpu/ppc/ppc.factor

@@ -96,10 +96,7 @@ HOOK: reserved-area-size os ( -- n )
 ! frame, 8 bytes in size. This is in the param-save area so it
 ! does not overlap with spill slots.
 : scratch@ ( n -- offset )
-    stack-frame get total-size>>
+    factor-area-size + ;
-    factor-area-size -
-    param-save-size -
-    + ;
 
 ! GC root area
 : gc-root@ ( n -- offset )

basis/iokit/iokit.factor

@@ -1,6 +1,6 @@
 USING: alien.syntax alien.c-types core-foundation
 core-foundation.bundles core-foundation.dictionaries system
-combinators kernel sequences debugger io accessors ;
+combinators kernel sequences io accessors ;
 IN: iokit
 
 <<
@@ -136,11 +136,9 @@ FUNCTION: IOReturn IORegistryEntryCreateCFProperties ( io_registry_entry_t entry
 
 FUNCTION: char* mach_error_string ( IOReturn error ) ;
 
-TUPLE: mach-error error-code ;
+TUPLE: mach-error error-code error-string ;
-C: <mach-error> mach-error
+: <mach-error> ( code -- error )
-
+    dup mach_error_string \ mach-error boa ;
-M: mach-error error.
-    "IOKit call failed: " print error-code>> mach_error_string print ;
 
 : mach-error ( return -- )
     dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;

basis/math/intervals/intervals-tests.factor

@@ -23,6 +23,10 @@ IN: math.intervals.tests
 
 [ T{ interval f { 1 t } { 1 t } } ] [ 1 [a,a] ] unit-test
 
+! Not sure how to handle NaNs yet...
+! [ 1 0/0. [a,b] ] must-fail
+! [ 0/0. 1 [a,b] ] must-fail
+
 [ t ] [ { 3 t } { 3 f } endpoint< ] unit-test
 [ t ] [ { 2 f } { 3 f } endpoint< ] unit-test
 [ f ] [ { 3 f } { 3 t } endpoint< ] unit-test
@@ -350,6 +354,10 @@ comparison-ops [
 
 [ t ] [ full-interval interval-abs [0,inf] = ] unit-test
 
+[ t ] [ [0,inf] interval-abs [0,inf] = ] unit-test
+
+[ t ] [ empty-interval interval-abs empty-interval = ] unit-test
+
 [ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test
 
 ! Test that commutative interval ops really are

basis/tools/continuations/continuations-docs.factor

@@ -0,0 +1,6 @@
+IN: tools.continuations
+USING: help.markup help.syntax ;
+
+HELP: break
+{ $description "A breakpoint. When this word is executed, the walker tool opens with execution suspended at the breakpoint's location." }
+{ $see-also "ui-walker" } ;

basis/tools/deploy/shaker/shaker.factor

@@ -202,17 +202,37 @@ IN: tools.deploy.shaker
         [ dup implementors [ "methods" word-prop delete-at ] with each ] each
     ] when ;
 
+: recursive-subst ( seq old new -- )
+    '[
+        _ _
+        {
+            ! old becomes new
+            { [ 3dup drop eq? ] [ 2nip ] }
+            ! recurse into arrays
+            { [ pick array? ] [ [ dup ] 2dip recursive-subst ] }
+            ! otherwise do nothing
+            [ 2drop ]
+        } cond
+    ] change-each ;
+
+: strip-default-method ( generic new-default -- )
+    [
+        [ "decision-tree" word-prop ]
+        [ "default-method" word-prop ] bi
+    ] dip
+    recursive-subst ;
+
+: new-default-method ( -- gensym )
+    [ [ "No method" throw ] (( -- * )) define-temp ] with-compilation-unit ;
+
 : strip-default-methods ( -- )
+    ! In a development image, each generic has its own default method.
+    ! This gives better error messages for runtime type errors, but
+    ! takes up space. For deployment we merge them all together.
     strip-debugger? [
         "Stripping default methods" show
-        [
+        [ single-generic? ] instances
-            [ generic? ] instances
+        new-default-method '[ _ strip-default-method ] each
-            [ "No method" throw ] (( -- * )) define-temp
-            dup t "default" set-word-prop
-            '[
-                [ _ "default-method" set-word-prop ] [ make-generic ] bi
-            ] each
-        ] with-compilation-unit
     ] when ;
 
 : strip-vocab-globals ( except names -- words )
@@ -361,8 +381,8 @@ IN: tools.deploy.shaker
     [ compress-object? ] [ ] "objects" compress ;
 
 : remain-compiled ( old new -- old new )
-    #! Quotations which were formerly compiled must remain
+    ! Quotations which were formerly compiled must remain
-    #! compiled.
+    ! compiled.
     2dup [
         2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
         [ nip jit-compile ] [ 2drop ] if
@@ -383,7 +403,9 @@ SYMBOL: deploy-vocab
         [ boot ] %
         init-hooks get values concat %
         strip-debugger? [ , ] [
-            ! Don't reference try directly
+            ! Don't reference 'try' directly since we don't want
+            ! to pull in the debugger and prettyprinter into every
+            ! deployed app
             [:c]
             [print-error]
             '[

basis/tools/deploy/shaker/strip-debugger.factor

@@ -12,7 +12,6 @@ IN: debugger
 "threads" vocab [
     [
         "error-in-thread" "threads" lookup
-        [ die 2drop ]
+        [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi
-        define
     ] with-compilation-unit
 ] when

basis/tools/walker/walker-docs.factor

@@ -0,0 +1,5 @@
+IN: tools.walker
+USING: help.syntax help.markup tools.continuations ;
+
+HELP: B
+{ $description "An alias for " { $link break } ", defined in the " { $vocab-link "syntax" } " vocabulary so that it is always available." } ;

basis/ui/tools/walker/walker-docs.factor

@@ -28,6 +28,7 @@ ARTICLE: "breakpoints" "Setting breakpoints"
 $nl
 "Breakpoints can be inserted directly into code:"
 { $subsection break }
+{ $subsection POSTPONE: B }
 "Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;
 
 ARTICLE: "ui-walker" "UI walker"