diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 38cb5c12fe..ee081a14ca 100644 --- a/basis/bootstrap/image/image.factor +++ b/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 +C: 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? - over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; +M: eql-wrapper equal? + over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ; + +TUPLE: eq-wrapper obj ; + +C: eq-wrapper + +M: eq-wrapper equal? + over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; SYMBOL: objects -: (objects) ( obj -- id assoc ) objects get ; inline +: cache-eql-object ( obj quot -- value ) + [ objects get ] dip '[ obj>> @ ] cache ; inline -: lookup-object ( obj -- n/f ) (objects) at ; +: cache-eq-object ( obj quot -- value ) + [ objects get ] dip '[ obj>> @ ] cache ; inline -: put-object ( n obj -- ) (objects) set-at ; +: lookup-object ( obj -- n/f ) objects get at ; -: cache-object ( obj quot -- value ) - [ (objects) ] dip '[ obj>> @ ] cache ; inline +: put-object ( n obj -- ) objects get set-at ; ! 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 ; + [ + byte-array [ + dup length emit-fixnum + pad-bytes emit-bytes + ] 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? [ ] 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 diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 2c472bc0ff..412451f640 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -179,4 +179,9 @@ IN: compiler.cfg.builder.tests [ f ] [ [ { 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 \ No newline at end of file diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index b8e5bdbe10..d6674e7097 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/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 - - param-save-size - - + ; + factor-area-size + ; ! GC root area : gc-root@ ( n -- offset ) diff --git a/basis/iokit/iokit.factor b/basis/iokit/iokit.factor index f7ea81c0c2..529db6bf78 100755 --- a/basis/iokit/iokit.factor +++ b/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 ; -C: mach-error - -M: mach-error error. - "IOKit call failed: " print error-code>> mach_error_string print ; +TUPLE: mach-error error-code error-string ; +: ( code -- error ) + dup mach_error_string \ mach-error boa ; : mach-error ( return -- ) dup KERN_SUCCESS = [ drop ] [ throw ] if ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index a2bdf6d98f..4e44fc1208 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/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 diff --git a/basis/tools/continuations/continuations-docs.factor b/basis/tools/continuations/continuations-docs.factor new file mode 100644 index 0000000000..bd69fb48ca --- /dev/null +++ b/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" } ; \ No newline at end of file diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 35e58a0aa7..c750c70e24 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/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 - [ - [ generic? ] instances - [ "No method" throw ] (( -- * )) define-temp - dup t "default" set-word-prop - '[ - [ _ "default-method" set-word-prop ] [ make-generic ] bi - ] each - ] with-compilation-unit + [ single-generic? ] instances + new-default-method '[ _ strip-default-method ] each ] 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 - #! compiled. + ! Quotations which were formerly compiled must remain + ! 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] '[ diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor index db7eb63bbf..b7565e7d9e 100644 --- a/basis/tools/deploy/shaker/strip-debugger.factor +++ b/basis/tools/deploy/shaker/strip-debugger.factor @@ -12,7 +12,6 @@ IN: debugger "threads" vocab [ [ "error-in-thread" "threads" lookup - [ die 2drop ] - define + [ [ die 2drop ] define ] [ f "combination" set-word-prop ] bi ] with-compilation-unit ] when diff --git a/basis/tools/walker/walker-docs.factor b/basis/tools/walker/walker-docs.factor new file mode 100644 index 0000000000..b636760634 --- /dev/null +++ b/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." } ; \ No newline at end of file diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor index 9e73a31282..ce354da268 100644 --- a/basis/ui/tools/walker/walker-docs.factor +++ b/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"