diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 7aea3c458a..0b5a63a906 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -44,33 +44,33 @@ PRIVATE> : ( n -- bit-array ) dup bits>bytes bit-array boa ; inline -M: bit-array length length>> ; +M: bit-array length length>> ; inline M: bit-array nth-unsafe - [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; + [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline M: bit-array set-nth-unsafe [ >fixnum ] [ underlying>> ] bi* [ byte/bit set-bit ] 2keep - swap n>byte set-alien-unsigned-1 ; + swap n>byte set-alien-unsigned-1 ; inline GENERIC: clear-bits ( bit-array -- ) -M: bit-array clear-bits 0 (set-bits) ; +M: bit-array clear-bits 0 (set-bits) ; inline GENERIC: set-bits ( bit-array -- ) -M: bit-array set-bits -1 (set-bits) ; +M: bit-array set-bits -1 (set-bits) ; inline M: bit-array clone - [ length>> ] [ underlying>> clone ] bi bit-array boa ; + [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline : >bit-array ( seq -- bit-array ) T{ bit-array f 0 B{ } } clone-like ; inline -M: bit-array like drop dup bit-array? [ >bit-array ] unless ; +M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline -M: bit-array new-sequence drop ; +M: bit-array new-sequence drop ; inline M: bit-array equal? over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; @@ -81,7 +81,7 @@ M: bit-array resize resize-byte-array ] 2bi bit-array boa - dup clean-up ; + dup clean-up ; inline M: bit-array byte-length length 7 + -3 shift ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor old mode 100644 new mode 100755 index 3b8d996f34..504acc74b0 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; } cond ; : optimize? ( word -- ? ) - { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; + single-generic? not ; : contains-breakpoints? ( -- ? ) dependencies get keys [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 73ff49259a..faf6968670 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -41,13 +41,13 @@ IN: compiler.tree.cleanup.tests GENERIC: mynot ( x -- y ) -M: f mynot drop t ; +M: f mynot drop t ; inline -M: object mynot drop f ; +M: object mynot drop f ; inline GENERIC: detect-f ( x -- y ) -M: f detect-f ; +M: f detect-f ; inline [ t ] [ [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined? @@ -55,9 +55,9 @@ M: f detect-f ; GENERIC: xyz ( n -- n ) -M: integer xyz ; +M: integer xyz ; inline -M: object xyz ; +M: object xyz ; inline [ t ] [ [ { integer } declare xyz ] \ xyz inlined? diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor old mode 100644 new mode 100755 index 9b278dde9b..fca35a5653 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences words memoize combinators -classes classes.builtin classes.tuple math.partial-dispatch -fry assocs combinators.short-circuit +classes classes.builtin classes.tuple classes.singleton +math.partial-dispatch fry assocs combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -45,6 +45,7 @@ M: predicate finalize-word "predicating" word-prop { { [ dup builtin-class? ] [ drop word>> cached-expansion ] } { [ dup tuple-class? ] [ drop word>> def>> splice-final ] } + { [ dup singleton-class? ] [ drop word>> def>> splice-final ] } [ drop ] } cond ; diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index a667ea727f..cdbeabe532 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -153,7 +153,7 @@ ERROR: uninferable ; : (value>quot) ( value-info -- quot ) dup class>> { - { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] } + { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] } { \ curry [ slots>> third (value>quot) '[ [ obj>> ] [ quot>> @ ] bi ] diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 1586f2ca0b..3836e0f3ba 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,8 +3,8 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations classes fry combinators.smart hints -locals +combinators.short-circuit words namespaces continuations classes +fry hints locals compiler.tree compiler.tree.builder compiler.tree.recursive @@ -14,19 +14,6 @@ compiler.tree.propagation.info compiler.tree.propagation.nodes ; IN: compiler.tree.propagation.inlining -! We count nodes up-front; if there are relatively few nodes, -! we are more eager to inline -SYMBOL: node-count - -: count-nodes ( nodes -- n ) - 0 swap [ drop 1 + ] each-node ; - -: compute-node-count ( nodes -- ) count-nodes node-count set ; - -! We try not to inline the same word too many times, to avoid -! combinatorial explosion -SYMBOL: inlining-count - ! Splicing nodes : splicing-call ( #call word -- nodes ) [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; @@ -101,99 +88,28 @@ M: callable splicing-nodes splicing-body ; dupd inlining-math-partial eliminate-dispatch ; ! Method body inlining -SYMBOL: recursive-calls -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - { - ! special-case - { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] } - ! not inline - { [ dup inline? not ] [ drop 1 ] } - ! recursive and inline - { [ dup recursive-calls get key? ] [ drop 10 ] } - ! inline - [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ] - } cond ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 2 + ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - [ drop 0 ] - } cond - ] sigma ; - -: flat-length ( word -- n ) - H{ } clone recursive-calls [ - [ recursive-calls get conjoin ] - [ def>> (flat-length) 5 /i ] - bi - ] with-variable ; - -: classes-known? ( #call -- ? ) - in-d>> [ - value-info class>> - [ class-types length 1 = ] - [ union-class? not ] - bi and - ] any? ; - -: node-count-bias ( -- n ) - 45 node-count get [-] 8 /i ; - -: body-length-bias ( word -- n ) - [ flat-length ] [ inlining-count get at 0 or ] bi - over 2 <= [ drop ] [ 2/ 1 + * ] if 24 swap [-] 4 /i ; - -: inlining-rank ( #call word -- n ) - [ - [ classes-known? 2 0 ? ] - [ - [ body-length-bias ] - [ "specializer" word-prop 1 0 ? ] - [ method-body? 1 0 ? ] - tri - node-count-bias - loop-nesting get 0 or 2 * - ] bi* - ] sum-outputs ; - -: should-inline? ( #call word -- ? ) - dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ; - SYMBOL: history : already-inlined? ( obj -- ? ) history get memq? ; : add-to-history ( obj -- ) history [ swap suffix ] change ; -: remember-inlining ( word -- ) - [ inlining-count get inc-at ] - [ add-to-history ] - bi ; - :: inline-word ( #call word -- ? ) word already-inlined? [ f ] [ #call word splicing-body [ [ - word remember-inlining - [ ] [ count-nodes ] [ (propagate) ] tri + word add-to-history + dup (propagate) ] with-scope - [ #call (>>body) ] [ node-count +@ ] bi* t + #call (>>body) t ] [ f ] if* ] if ; -: inline-method-body ( #call word -- ? ) - 2dup should-inline? [ inline-word ] [ 2drop f ] if ; - : always-inline-word? ( word -- ? ) { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ; + { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; @@ -217,7 +133,7 @@ SYMBOL: history { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ dup method-body? ] [ inline-method-body ] } + { [ dup inline? ] [ inline-word ] } [ 2drop f ] } cond ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index eb9591c40c..1c9b27dfbc 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -56,9 +56,9 @@ IN: compiler.tree.propagation.tests [ float ] [ [ { float real } declare + ] final-math-class ] unit-test -[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test +! [ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test -[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test +! [ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test [ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test @@ -444,6 +444,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] final-classes ] unit-test +[ V{ f { } } ] [ + [ + T{ mixed-mutable-immutable f 3 { } } + [ x>> ] [ y>> ] bi + ] final-literals +] unit-test + ! Recursive propagation : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive @@ -502,8 +509,8 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test GENERIC: iterate ( obj -- next-obj ? ) -M: fixnum iterate f ; -M: array iterate first t ; +M: fixnum iterate f ; inline +M: array iterate first t ; inline : dead-loop ( obj -- final-obj ) iterate [ dead-loop ] when ; inline recursive @@ -567,7 +574,7 @@ M: array iterate first t ; ] unit-test GENERIC: bad-generic ( a -- b ) -M: fixnum bad-generic 1 fixnum+fast ; +M: fixnum bad-generic 1 fixnum+fast ; inline : bad-behavior ( -- b ) 4 bad-generic ; inline recursive [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test @@ -740,7 +747,7 @@ TUPLE: foo bar ; [ t ] [ [ foo new ] { new } inlined? ] unit-test GENERIC: whatever ( x -- y ) -M: number whatever drop foo ; +M: number whatever drop foo ; inline [ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test @@ -749,8 +756,8 @@ M: number whatever drop foo ; [ f ] [ [ that-thing new ] { new } inlined? ] unit-test GENERIC: whatever2 ( x -- y ) -M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; -M: f whatever2 ; +M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline +M: f whatever2 ; inline [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test [ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index 3dd2c4998a..a11264fb7f 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -19,6 +19,4 @@ IN: compiler.tree.propagation H{ } clone copies set H{ } clone 1array value-infos set H{ } clone 1array constraints set - H{ } clone inlining-count set - dup compute-node-count dup (propagate) ; diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index f68760a4e1..83579d2beb 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -18,41 +18,41 @@ GENERIC: group@ ( n groups -- from to seq ) M: chunking-seq set-nth group@ 0 swap copy ; -M: chunking-seq like drop { } like ; +M: chunking-seq like drop { } like ; inline INSTANCE: chunking-seq sequence MIXIN: subseq-chunking -M: subseq-chunking nth group@ subseq ; +M: subseq-chunking nth group@ subseq ; inline MIXIN: slice-chunking -M: slice-chunking nth group@ ; +M: slice-chunking nth group@ ; inline -M: slice-chunking nth-unsafe group@ slice boa ; +M: slice-chunking nth-unsafe group@ slice boa ; inline TUPLE: abstract-groups < chunking-seq ; M: abstract-groups length - [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; + [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline M: abstract-groups set-length - [ n>> * ] [ seq>> ] bi set-length ; + [ n>> * ] [ seq>> ] bi set-length ; inline M: abstract-groups group@ - [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; + [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline TUPLE: abstract-clumps < chunking-seq ; M: abstract-clumps length - [ seq>> length ] [ n>> ] bi - 1 + ; + [ seq>> length ] [ n>> ] bi - 1 + ; inline M: abstract-clumps set-length - [ n>> + 1 - ] [ seq>> ] bi set-length ; + [ n>> + 1 - ] [ seq>> ] bi set-length ; inline M: abstract-clumps group@ - [ n>> over + ] [ seq>> ] bi ; + [ n>> over + ] [ seq>> ] bi ; inline PRIVATE> diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor index 16132ca810..00d3bc7509 100644 --- a/basis/io/encodings/ascii/ascii.factor +++ b/basis/io/encodings/ascii/ascii.factor @@ -16,7 +16,7 @@ PRIVATE> SINGLETON: ascii M: ascii encode-char - 128 encode-if< ; + 128 encode-if< ; inline M: ascii decode-char - 128 decode-if< ; + 128 decode-if< ; inline diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index e469140ff4..4de49c06a7 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -9,9 +9,9 @@ C: bits : make-bits ( number -- bits ) [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] if-zero ; inline -M: bits length length>> ; +M: bits length length>> ; inline -M: bits nth-unsafe number>> swap bit? ; +M: bits nth-unsafe number>> swap bit? ; inline INSTANCE: bits immutable-sequence diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index 832a9e64ba..ce94dfaca8 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -5,29 +5,29 @@ math.libm math.functions arrays math.functions.private sequences parser ; IN: math.complex.private -M: real real-part ; -M: real imaginary-part drop 0 ; -M: complex real-part real>> ; -M: complex imaginary-part imaginary>> ; -M: complex absq >rect [ sq ] bi@ + ; -M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; +M: real real-part ; inline +M: real imaginary-part drop 0 ; inline +M: complex real-part real>> ; inline +M: complex imaginary-part imaginary>> ; inline +M: complex absq >rect [ sq ] bi@ + ; inline +M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline : componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline : complex= ( x y quot -- ? ) componentwise and ; inline -M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; -M: complex number= [ number= ] complex= ; +M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline +M: complex number= [ number= ] complex= ; inline : complex-op ( x y quot -- z ) componentwise rect> ; inline -M: complex + [ + ] complex-op ; -M: complex - [ - ] complex-op ; +M: complex + [ + ] complex-op ; inline +M: complex - [ - ] complex-op ; inline : *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline : *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline -M: complex * [ *re - ] [ *im + ] 2bi rect> ; +M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline : (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline : complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline -M: complex / [ / ] complex/ ; -M: complex /f [ /f ] complex/ ; -M: complex /i [ /i ] complex/ ; -M: complex abs absq >float fsqrt ; -M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; +M: complex / [ / ] complex/ ; inline +M: complex /f [ /f ] complex/ ; inline +M: complex /i [ /i ] complex/ ; inline +M: complex abs absq >float fsqrt ; inline +M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline IN: syntax diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 801522b376..0daea7f706 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -13,7 +13,7 @@ IN: math.functions GENERIC: sqrt ( x -- y ) foldable M: real sqrt - >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; + >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline : factor-2s ( n -- r s ) #! factor an integer into 2^r * s @@ -120,7 +120,7 @@ ERROR: non-trivial-divisor n ; GENERIC: absq ( x -- y ) foldable -M: real absq sq ; +M: real absq sq ; inline : ~abs ( x y epsilon -- ? ) [ - abs ] dip < ; @@ -148,13 +148,13 @@ M: real absq sq ; GENERIC: exp ( x -- y ) -M: real exp fexp ; +M: real exp fexp ; inline M: complex exp >rect swap fexp swap polar> ; GENERIC: log ( x -- y ) -M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; +M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline M: complex log >polar swap flog swap rect> ; @@ -169,7 +169,7 @@ M: complex cos [ [ fcos ] [ fcosh ] bi* * ] [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ; -M: real cos fcos ; +M: real cos fcos ; inline : sec ( x -- y ) cos recip ; inline @@ -180,7 +180,7 @@ M: complex cosh [ [ fcosh ] [ fcos ] bi* * ] [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ; -M: real cosh fcosh ; +M: real cosh fcosh ; inline : sech ( x -- y ) cosh recip ; inline @@ -191,7 +191,7 @@ M: complex sin [ [ fsin ] [ fcosh ] bi* * ] [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ; -M: real sin fsin ; +M: real sin fsin ; inline : cosec ( x -- y ) sin recip ; inline @@ -202,7 +202,7 @@ M: complex sinh [ [ fsinh ] [ fcos ] bi* * ] [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ; -M: real sinh fsinh ; +M: real sinh fsinh ; inline : cosech ( x -- y ) sinh recip ; inline @@ -210,13 +210,13 @@ GENERIC: tan ( x -- y ) foldable M: complex tan [ sin ] [ cos ] bi / ; -M: real tan ftan ; +M: real tan ftan ; inline GENERIC: tanh ( x -- y ) foldable M: complex tanh [ sinh ] [ cosh ] bi / ; -M: real tanh ftanh ; +M: real tanh ftanh ; inline : cot ( x -- y ) tan recip ; inline @@ -252,7 +252,7 @@ GENERIC: atan ( x -- y ) foldable M: complex atan i* atanh i* ; -M: real atan fatan ; +M: real atan fatan ; inline : asec ( x -- y ) recip acos ; inline diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index d28afa1413..58cb2b09db 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -12,11 +12,9 @@ TUPLE: range : ( a b step -- range ) [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline -M: range length ( seq -- n ) - length>> ; +M: range length ( seq -- n ) length>> ; inline -M: range nth-unsafe ( n range -- obj ) - [ step>> * ] keep from>> + ; +M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline ! For ranges with many elements, the default element-wise methods ! sequences define are unsuitable because they're O(n) diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 7da92cd154..dcb8e87e7c 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -48,8 +48,8 @@ M: ratio >fixnum >fraction /i >fixnum ; M: ratio >bignum >fraction /i >bignum ; M: ratio >float >fraction /f ; -M: ratio numerator numerator>> ; -M: ratio denominator denominator>> ; +M: ratio numerator numerator>> ; inline +M: ratio denominator denominator>> ; inline M: ratio < scale < ; M: ratio <= scale <= ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0edbe5e53d..ea8f6f5f49 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -158,6 +158,8 @@ M: bad-executable summary \ [ infer- ] "special" set-word-prop +\ t "flushable" set-word-prop + : infer-effect-unsafe ( word -- ) pop-literal nip add-effect-input diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 761dbd816a..92e7541616 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -54,17 +54,17 @@ TUPLE: CLASS-array [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep \ CLASS-array boa ; inline -M: CLASS-array length length>> ; +M: CLASS-array length length>> ; inline -M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline -M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline -M: CLASS-array new-sequence drop ; +M: CLASS-array new-sequence drop ; inline : >CLASS-array ( seq -- tuple-array ) 0 clone-like ; -M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline INSTANCE: CLASS-array sequence diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor index 47a6c2090a..b70c7c5050 100644 --- a/basis/vectors/functor/functor.factor +++ b/basis/vectors/functor/functor.factor @@ -18,11 +18,11 @@ TUPLE: V { underlying A } { length array-capacity } ; M: V like drop dup V instance? [ dup A instance? [ dup length V boa ] [ >V ] if - ] unless ; + ] unless ; inline -M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; inline -M: A new-resizable drop ; +M: A new-resizable drop ; inline M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 864700cb0f..d6a08325d9 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,5 +1,5 @@ USING: alien alien.syntax alien.c-types alien.strings math -kernel sequences windows.errors windows.types debugger io +kernel sequences windows.errors windows.types io accessors math.order namespaces make math.parser windows.kernel32 combinators locals specialized-arrays.direct.uchar ; IN: windows.ole32 @@ -116,11 +116,10 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; : succeeded? ( hresult -- ? ) 0 HEX: 7FFFFFFF between? ; -TUPLE: ole32-error error-code ; -C: ole32-error +TUPLE: ole32-error code message ; -M: ole32-error error. - "COM method failed: " print error-code>> n>win32-error-string print ; +: ( code -- error ) + dup n>win32-error-string \ ole32-error boa ; : ole32-error ( hresult -- ) dup succeeded? [ drop ] [ throw ] if ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ec38e3be5b..d98ea3d103 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -20,11 +20,11 @@ UNION: pinned-c-ptr GENERIC: >c-ptr ( obj -- c-ptr ) -M: c-ptr >c-ptr ; +M: c-ptr >c-ptr ; inline SLOT: underlying -M: object >c-ptr underlying>> ; +M: object >c-ptr underlying>> ; inline GENERIC: expired? ( c-ptr -- ? ) flushable diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index dd70e45b6b..fa4d4b2f69 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -4,17 +4,17 @@ USING: accessors kernel kernel.private math math.private sequences sequences.private ; IN: arrays -M: array clone (clone) ; -M: array length length>> ; -M: array nth-unsafe [ >fixnum ] dip array-nth ; -M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; -M: array resize resize-array ; +M: array clone (clone) ; inline +M: array length length>> ; inline +M: array nth-unsafe [ >fixnum ] dip array-nth ; inline +M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline +M: array resize resize-array ; inline : >array ( seq -- array ) { } clone-like ; -M: object new-sequence drop 0 ; +M: object new-sequence drop 0 ; inline -M: f new-sequence drop [ f ] [ 0 ] if-zero ; +M: f new-sequence drop [ f ] [ 0 ] if-zero ; inline M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 8b6809236c..e633a54843 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -17,7 +17,7 @@ GENERIC: assoc-like ( assoc exemplar -- newassoc ) GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) -M: assoc assoc-like drop ; +M: assoc assoc-like drop ; inline : ?at ( key assoc -- value/key ? ) 2dup at* [ 2nip t ] [ 2drop f ] if ; inline @@ -87,7 +87,7 @@ PRIVATE> M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ dup assoc-size ] dip new-assoc - [ [ set-at ] with-assoc assoc-each ] keep ; + [ [ set-at ] with-assoc assoc-each ] keep ; inline : keys ( assoc -- keys ) [ drop ] { } assoc>map ; @@ -189,48 +189,48 @@ M: sequence set-at [ 2nip set-second ] [ drop [ swap 2array ] dip push ] if ; -M: sequence new-assoc drop ; +M: sequence new-assoc drop ; inline -M: sequence clear-assoc delete-all ; +M: sequence clear-assoc delete-all ; inline M: sequence delete-at [ nip ] [ search-alist nip ] 2bi [ swap delete-nth ] [ drop ] if* ; -M: sequence assoc-size length ; +M: sequence assoc-size length ; inline M: sequence assoc-clone-like - [ >alist ] dip clone-like ; + [ >alist ] dip clone-like ; inline M: sequence assoc-like - [ >alist ] dip like ; + [ >alist ] dip like ; inline -M: sequence >alist ; +M: sequence >alist ; inline ! Override sequence => assoc instance for f -M: f clear-assoc drop ; +M: f clear-assoc drop ; inline -M: f assoc-like drop dup assoc-empty? [ drop f ] when ; +M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline INSTANCE: sequence assoc -TUPLE: enum seq ; +TUPLE: enum { seq read-only } ; C: enum M: enum at* seq>> 2dup bounds-check? - [ nth t ] [ 2drop f f ] if ; + [ nth t ] [ 2drop f f ] if ; inline -M: enum set-at seq>> set-nth ; +M: enum set-at seq>> set-nth ; inline -M: enum delete-at seq>> delete-nth ; +M: enum delete-at seq>> delete-nth ; inline M: enum >alist ( enum -- alist ) - seq>> [ length ] keep zip ; + seq>> [ length ] keep zip ; inline -M: enum assoc-size seq>> length ; +M: enum assoc-size seq>> length ; inline -M: enum clear-assoc seq>> delete-all ; +M: enum clear-assoc seq>> delete-all ; inline INSTANCE: enum assoc diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 72989ac447..3c89a5f63e 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -4,18 +4,18 @@ USING: accessors kernel kernel.private alien.accessors sequences sequences.private math ; IN: byte-arrays -M: byte-array clone (clone) ; -M: byte-array length length>> ; -M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; -M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; +M: byte-array clone (clone) ; inline +M: byte-array length length>> ; inline +M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline +M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline -M: byte-array new-sequence drop (byte-array) ; +M: byte-array new-sequence drop (byte-array) ; inline M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; M: byte-array resize - resize-byte-array ; + resize-byte-array ; inline INSTANCE: byte-array sequence diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index fc3d9501c7..287e972405 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -18,15 +18,15 @@ M: byte-vector like drop dup byte-vector? [ dup byte-array? [ dup length byte-vector boa ] [ >byte-vector ] if - ] unless ; + ] unless ; inline M: byte-vector new-sequence - drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; + drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; -M: byte-vector contract 2drop ; +M: byte-vector contract 2drop ; inline M: byte-array like #! If we have an byte-array, we're done. @@ -39,8 +39,8 @@ M: byte-array like 2dup length eq? [ nip ] [ resize-byte-array ] if ] [ >byte-array ] if - ] unless ; + ] unless ; inline -M: byte-array new-resizable drop ; +M: byte-array new-resizable drop ; inline INSTANCE: byte-vector growable diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index c74c8f3b50..8eeb4ce357 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -20,9 +20,9 @@ PREDICATE: hi-tag-class < builtin-class class>type 7 > ; : bootstrap-type>class ( n -- class ) builtins get nth ; -M: hi-tag class hi-tag type>class ; +M: hi-tag class hi-tag type>class ; inline -M: object class tag type>class ; +M: object class tag type>class ; inline M: builtin-class rank-class drop 0 ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8e49e2f5f4..0a437a3d69 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -29,7 +29,7 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) : layout-of ( tuple -- layout ) 1 slot { array } declare ; inline -M: tuple class layout-of 2 slot { word } declare ; +M: tuple class layout-of 2 slot { word } declare ; inline : tuple-size ( tuple -- size ) layout-of 3 slot { fixnum } declare ; inline @@ -323,7 +323,7 @@ M: tuple-class (classes-intersect?) [ swap classes-intersect? ] } cond ; -M: tuple clone (clone) ; +M: tuple clone (clone) ; inline M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 754a3293d1..68a8de3d43 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -9,9 +9,9 @@ MIXIN: growable SLOT: length SLOT: underlying -M: growable length length>> ; -M: growable nth-unsafe underlying>> nth-unsafe ; -M: growable set-nth-unsafe underlying>> set-nth-unsafe ; +M: growable length length>> ; inline +M: growable nth-unsafe underlying>> nth-unsafe ; inline +M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline : capacity ( seq -- n ) underlying>> length ; inline @@ -49,21 +49,21 @@ M: growable set-length ( n seq -- ) [ >fixnum ] dip ] if ; inline -M: growable set-nth ensure set-nth-unsafe ; +M: growable set-nth ensure set-nth-unsafe ; inline -M: growable clone (clone) [ clone ] change-underlying ; +M: growable clone (clone) [ clone ] change-underlying ; inline M: growable lengthen ( n seq -- ) 2dup length > [ 2dup capacity > [ over new-size over expand ] when 2dup (>>length) - ] when 2drop ; + ] when 2drop ; inline M: growable shorten ( n seq -- ) growable-check 2dup length < [ 2dup contract 2dup (>>length) - ] when 2drop ; + ] when 2drop ; inline INSTANCE: growable sequence diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 03bc3e01fd..8547f53a0e 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -112,7 +112,7 @@ M: hashtable delete-at ( key hash -- ) ] if ; M: hashtable assoc-size ( hash -- n ) - [ count>> ] [ deleted>> ] bi - ; + [ count>> ] [ deleted>> ] bi - ; inline : rehash ( hash -- ) dup >alist [ @@ -150,7 +150,7 @@ M: hashtable >alist ] keep { } like ; M: hashtable clone - (clone) [ clone ] change-array ; + (clone) [ clone ] change-array ; inline M: hashtable equal? over hashtable? [ @@ -159,15 +159,15 @@ M: hashtable equal? ] [ 2drop f ] if ; ! Default method -M: assoc new-assoc drop ; +M: assoc new-assoc drop ; inline -M: f new-assoc drop ; +M: f new-assoc drop ; inline : >hashtable ( assoc -- hashtable ) H{ } assoc-clone-like ; M: hashtable assoc-like - drop dup hashtable? [ >hashtable ] unless ; + drop dup hashtable? [ >hashtable ] unless ; inline : ?set-at ( value key assoc/f -- assoc ) [ [ set-at ] keep ] [ associate ] if* ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index a722655cad..2911385c09 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -40,7 +40,7 @@ SINGLETON: utf8 dup stream-read1 dup [ begin-utf8 ] when nip ; inline M: utf8 decode-char - drop decode-utf8 ; + drop decode-utf8 ; inline ! Encoding UTF-8 diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d6350e0420..838d877a40 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -192,19 +192,19 @@ UNION: boolean POSTPONE: t POSTPONE: f ; ! Object protocol GENERIC: hashcode* ( depth obj -- code ) -M: object hashcode* 2drop 0 ; +M: object hashcode* 2drop 0 ; inline -M: f hashcode* 2drop 31337 ; +M: f hashcode* 2drop 31337 ; inline : hashcode ( obj -- code ) 3 swap hashcode* ; inline GENERIC: equal? ( obj1 obj2 -- ? ) -M: object equal? 2drop f ; +M: object equal? 2drop f ; inline TUPLE: identity-tuple ; -M: identity-tuple equal? 2drop f ; +M: identity-tuple equal? 2drop f ; inline : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ @@ -213,9 +213,9 @@ M: identity-tuple equal? 2drop f ; GENERIC: clone ( obj -- cloned ) -M: object clone ; +M: object clone ; inline -M: callstack clone (clone) ; +M: callstack clone (clone) ; inline ! Tuple construction GENERIC: new ( class -- tuple ) diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 42898fc085..5738c2ec99 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -78,6 +78,6 @@ M: bignum >integer M: real >integer dup most-negative-fixnum most-positive-fixnum between? - [ >fixnum ] [ >bignum ] if ; + [ >fixnum ] [ >bignum ] if ; inline UNION: immediate fixnum POSTPONE: f ; diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index 1305f2a18d..ed4947e1f5 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -10,21 +10,21 @@ HELP: >float HELP: bits>double ( n -- x ) { $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a " { $link float } " object from a 64-bit binary representation. This word is usually used to reconstruct floats read from streams." } ; { bits>double bits>float double>bits float>bits } related-words HELP: bits>float ( n -- x ) { $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a " { $link float } " object from a 32-bit binary representation. This word is usually used to reconstruct floats read from streams." } ; HELP: double>bits ( x -- n ) { $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a 64-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ; HELP: float>bits ( x -- n ) { $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } } -{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ; +{ $description "Creates a 32-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ; ! Unsafe primitives HELP: float+ ( x y -- z ) diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 2a22dc4330..160b220173 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,28 +3,28 @@ USING: kernel math math.private ; IN: math.floats.private -M: fixnum >float fixnum>float ; -M: bignum >float bignum>float ; +M: fixnum >float fixnum>float ; inline +M: bignum >float bignum>float ; inline -M: float >fixnum float>fixnum ; -M: float >bignum float>bignum ; -M: float >float ; +M: float >fixnum float>fixnum ; inline +M: float >bignum float>bignum ; inline +M: float >float ; inline -M: float hashcode* nip float>bits ; -M: float equal? over float? [ float= ] [ 2drop f ] if ; -M: float number= float= ; +M: float hashcode* nip float>bits ; inline +M: float equal? over float? [ float= ] [ 2drop f ] if ; inline +M: float number= float= ; inline -M: float < float< ; -M: float <= float<= ; -M: float > float> ; -M: float >= float>= ; +M: float < float< ; inline +M: float <= float<= ; inline +M: float > float> ; inline +M: float >= float>= ; inline -M: float + float+ ; -M: float - float- ; -M: float * float* ; -M: float / float/f ; -M: float /f float/f ; -M: float /i float/f >integer ; -M: float mod float-mod ; +M: float + float+ ; inline +M: float - float- ; inline +M: float * float* ; inline +M: float / float/f ; inline +M: float /f float/f ; inline +M: float /i float/f >integer ; inline +M: float mod float-mod ; inline -M: real abs dup 0 < [ neg ] when ; +M: real abs dup 0 < [ neg ] when ; inline diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 2b35ef76fd..75abd8087e 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -5,79 +5,79 @@ USING: kernel kernel.private sequences sequences.private math math.private combinators ; IN: math.integers.private -M: integer numerator ; -M: integer denominator drop 1 ; +M: integer numerator ; inline +M: integer denominator drop 1 ; inline -M: fixnum >fixnum ; -M: fixnum >bignum fixnum>bignum ; -M: fixnum >integer ; +M: fixnum >fixnum ; inline +M: fixnum >bignum fixnum>bignum ; inline +M: fixnum >integer ; inline -M: fixnum hashcode* nip ; -M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; -M: fixnum number= eq? ; +M: fixnum hashcode* nip ; inline +M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline +M: fixnum number= eq? ; inline -M: fixnum < fixnum< ; -M: fixnum <= fixnum<= ; -M: fixnum > fixnum> ; -M: fixnum >= fixnum>= ; +M: fixnum < fixnum< ; inline +M: fixnum <= fixnum<= ; inline +M: fixnum > fixnum> ; inline +M: fixnum >= fixnum>= ; inline -M: fixnum + fixnum+ ; -M: fixnum - fixnum- ; -M: fixnum * fixnum* ; -M: fixnum /i fixnum/i ; -M: fixnum /f [ >float ] dip >float float/f ; +M: fixnum + fixnum+ ; inline +M: fixnum - fixnum- ; inline +M: fixnum * fixnum* ; inline +M: fixnum /i fixnum/i ; inline +M: fixnum /f [ >float ] dip >float float/f ; inline -M: fixnum mod fixnum-mod ; +M: fixnum mod fixnum-mod ; inline -M: fixnum /mod fixnum/mod ; +M: fixnum /mod fixnum/mod ; inline -M: fixnum bitand fixnum-bitand ; -M: fixnum bitor fixnum-bitor ; -M: fixnum bitxor fixnum-bitxor ; -M: fixnum shift >fixnum fixnum-shift ; +M: fixnum bitand fixnum-bitand ; inline +M: fixnum bitor fixnum-bitor ; inline +M: fixnum bitxor fixnum-bitxor ; inline +M: fixnum shift >fixnum fixnum-shift ; inline -M: fixnum bitnot fixnum-bitnot ; +M: fixnum bitnot fixnum-bitnot ; inline -M: fixnum bit? neg shift 1 bitand 0 > ; +M: fixnum bit? neg shift 1 bitand 0 > ; inline : fixnum-log2 ( x -- n ) 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ; -M: fixnum (log2) fixnum-log2 ; +M: fixnum (log2) fixnum-log2 ; inline -M: bignum >fixnum bignum>fixnum ; -M: bignum >bignum ; +M: bignum >fixnum bignum>fixnum ; inline +M: bignum >bignum ; inline M: bignum hashcode* nip >fixnum ; M: bignum equal? over bignum? [ bignum= ] [ swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if - ] if ; + ] if ; inline -M: bignum number= bignum= ; +M: bignum number= bignum= ; inline -M: bignum < bignum< ; -M: bignum <= bignum<= ; -M: bignum > bignum> ; -M: bignum >= bignum>= ; +M: bignum < bignum< ; inline +M: bignum <= bignum<= ; inline +M: bignum > bignum> ; inline +M: bignum >= bignum>= ; inline -M: bignum + bignum+ ; -M: bignum - bignum- ; -M: bignum * bignum* ; -M: bignum /i bignum/i ; -M: bignum mod bignum-mod ; +M: bignum + bignum+ ; inline +M: bignum - bignum- ; inline +M: bignum * bignum* ; inline +M: bignum /i bignum/i ; inline +M: bignum mod bignum-mod ; inline -M: bignum /mod bignum/mod ; +M: bignum /mod bignum/mod ; inline -M: bignum bitand bignum-bitand ; -M: bignum bitor bignum-bitor ; -M: bignum bitxor bignum-bitxor ; -M: bignum shift >fixnum bignum-shift ; +M: bignum bitand bignum-bitand ; inline +M: bignum bitor bignum-bitor ; inline +M: bignum bitxor bignum-bitxor ; inline +M: bignum shift >fixnum bignum-shift ; inline -M: bignum bitnot bignum-bitnot ; -M: bignum bit? bignum-bit? ; -M: bignum (log2) bignum-log2 ; +M: bignum bitnot bignum-bitnot ; inline +M: bignum bit? bignum-bit? ; inline +M: bignum (log2) bignum-log2 ; inline ! Converting ratios to floats. Based on FLOAT-RATIO from ! sbcl/src/code/float.lisp, which has the following license: diff --git a/core/math/math.factor b/core/math/math.factor index a00f2240e1..1213e13a1f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -98,38 +98,38 @@ GENERIC: fp-infinity? ( x -- ? ) GENERIC: fp-nan-payload ( x -- bits ) M: object fp-special? - drop f ; + drop f ; inline M: object fp-nan? - drop f ; + drop f ; inline M: object fp-qnan? - drop f ; + drop f ; inline M: object fp-snan? - drop f ; + drop f ; inline M: object fp-infinity? - drop f ; + drop f ; inline M: object fp-nan-payload - drop f ; + drop f ; inline M: float fp-special? - double>bits -52 shift HEX: 7ff [ bitand ] keep = ; + double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline M: float fp-nan-payload - double>bits HEX: fffffffffffff bitand ; foldable flushable + double>bits HEX: fffffffffffff bitand ; inline M: float fp-nan? - dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; + dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline M: float fp-qnan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline M: float fp-snan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline M: float fp-infinity? - dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; + dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline : ( payload -- nan ) - HEX: 7ff0000000000000 bitor bits>double ; foldable flushable + HEX: 7ff0000000000000 bitor bits>double ; inline : next-float ( m -- n ) double>bits @@ -137,7 +137,7 @@ M: float fp-infinity? dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero 1 + bits>double ! positive ] if - ] if ; foldable flushable + ] if ; inline : prev-float ( m -- n ) double>bits @@ -145,7 +145,7 @@ M: float fp-infinity? dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero 1 - bits>double ! positive non-zero ] if - ] if ; foldable flushable + ] if ; inline : next-power-of-2 ( m -- n ) dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 435eec9b96..707dc02af2 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -15,24 +15,24 @@ GENERIC: <=> ( obj1 obj2 -- <=> ) : >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline -M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; +M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline GENERIC: before? ( obj1 obj2 -- ? ) GENERIC: after? ( obj1 obj2 -- ? ) GENERIC: before=? ( obj1 obj2 -- ? ) GENERIC: after=? ( obj1 obj2 -- ? ) -M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; -M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; -M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; -M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; +M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline +M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline +M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline +M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline -M: real before? ( obj1 obj2 -- ? ) < ; -M: real after? ( obj1 obj2 -- ? ) > ; -M: real before=? ( obj1 obj2 -- ? ) <= ; -M: real after=? ( obj1 obj2 -- ? ) >= ; +M: real before? ( obj1 obj2 -- ? ) < ; inline +M: real after? ( obj1 obj2 -- ? ) > ; inline +M: real before=? ( obj1 obj2 -- ? ) <= ; inline +M: real after=? ( obj1 obj2 -- ? ) >= ; inline -: min ( x y -- z ) [ before? ] most ; inline +: min ( x y -- z ) [ before? ] most ; inline : max ( x y -- z ) [ after? ] most ; inline : clamp ( x min max -- y ) [ max ] dip min ; inline diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 0b2c170c1e..49b6ec1374 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -11,24 +11,24 @@ TUPLE: sbuf : ( n -- sbuf ) 0 0 sbuf boa ; inline M: sbuf set-nth-unsafe - [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; + [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline M: sbuf new-sequence - drop [ 0 ] [ >fixnum ] bi sbuf boa ; + drop [ 0 ] [ >fixnum ] bi sbuf boa ; inline : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline M: sbuf like drop dup sbuf? [ dup string? [ dup length sbuf boa ] [ >sbuf ] if - ] unless ; + ] unless ; inline -M: sbuf new-resizable drop ; +M: sbuf new-resizable drop ; inline M: sbuf equal? over sbuf? [ sequence= ] [ 2drop f ] if ; -M: string new-resizable drop ; +M: string new-resizable drop ; inline M: string like #! If we have a string, we're done. @@ -41,6 +41,6 @@ M: string like 2dup length eq? [ nip dup reset-string-hashcode ] [ resize-string ] if ] [ >string ] if - ] unless ; + ] unless ; inline INSTANCE: sbuf growable diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 84b80794a3..031d5f7b4a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -18,14 +18,14 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable : new-like ( len exemplar quot -- seq ) over [ [ new-sequence ] dip call ] dip like ; inline -M: sequence like drop ; +M: sequence like drop ; inline GENERIC: lengthen ( n seq -- ) GENERIC: shorten ( n seq -- ) -M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; +M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline -M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; +M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline : empty? ( seq -- ? ) length 0 = ; inline @@ -82,25 +82,25 @@ GENERIC: resize ( n seq -- newseq ) flushable GENERIC: nth-unsafe ( n seq -- elt ) flushable GENERIC: set-nth-unsafe ( elt n seq -- ) -M: sequence nth bounds-check nth-unsafe ; -M: sequence set-nth bounds-check set-nth-unsafe ; +M: sequence nth bounds-check nth-unsafe ; inline +M: sequence set-nth bounds-check set-nth-unsafe ; inline -M: sequence nth-unsafe nth ; -M: sequence set-nth-unsafe set-nth ; +M: sequence nth-unsafe nth ; inline +M: sequence set-nth-unsafe set-nth ; inline : change-nth-unsafe ( i seq quot -- ) [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline ! The f object supports the sequence protocol trivially -M: f length drop 0 ; -M: f nth-unsafe nip ; -M: f like drop [ f ] when-empty ; +M: f length drop 0 ; inline +M: f nth-unsafe nip ; inline +M: f like drop [ f ] when-empty ; inline INSTANCE: f immutable-sequence ! Integers support the sequence protocol -M: integer length ; -M: integer nth-unsafe drop ; +M: integer length ; inline +M: integer nth-unsafe drop ; inline INSTANCE: integer immutable-sequence @@ -113,8 +113,8 @@ TUPLE: iota { n integer read-only } ; > ; -M: iota nth-unsafe drop ; +M: iota length n>> ; inline +M: iota nth-unsafe drop ; inline INSTANCE: iota immutable-sequence @@ -185,12 +185,12 @@ MIXIN: virtual-sequence GENERIC: virtual-seq ( seq -- seq' ) GENERIC: virtual@ ( n seq -- n' seq' ) -M: virtual-sequence nth virtual@ nth ; -M: virtual-sequence set-nth virtual@ set-nth ; -M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; -M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; -M: virtual-sequence like virtual-seq like ; -M: virtual-sequence new-sequence virtual-seq new-sequence ; +M: virtual-sequence nth virtual@ nth ; inline +M: virtual-sequence set-nth virtual@ set-nth ; inline +M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline +M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline +M: virtual-sequence like virtual-seq like ; inline +M: virtual-sequence new-sequence virtual-seq new-sequence ; inline INSTANCE: virtual-sequence sequence @@ -199,11 +199,9 @@ TUPLE: reversed { seq read-only } ; C: reversed -M: reversed virtual-seq seq>> ; - -M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; - -M: reversed length seq>> length ; +M: reversed virtual-seq seq>> ; inline +M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline +M: reversed length seq>> length ; inline INSTANCE: reversed virtual-sequence @@ -233,11 +231,11 @@ TUPLE: slice-error from to seq reason ; check-slice slice boa ; inline -M: slice virtual-seq seq>> ; +M: slice virtual-seq seq>> ; inline -M: slice virtual@ [ from>> + ] [ seq>> ] bi ; +M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline -M: slice length [ to>> ] [ from>> ] bi - ; +M: slice length [ to>> ] [ from>> ] bi - ; inline : short ( seq n -- seq n' ) over length min ; inline @@ -260,8 +258,8 @@ TUPLE: repetition { len read-only } { elt read-only } ; C: repetition -M: repetition length len>> ; -M: repetition nth-unsafe nip elt>> ; +M: repetition length len>> ; inline +M: repetition nth-unsafe nip elt>> ; inline INSTANCE: repetition immutable-sequence @@ -316,9 +314,9 @@ PRIVATE> (copy) drop ; inline M: sequence clone-like - [ dup length ] dip new-sequence [ 0 swap copy ] keep ; + [ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline -M: immutable-sequence clone-like like ; +M: immutable-sequence clone-like like ; inline : push-all ( src dest -- ) [ length ] [ copy ] bi ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 9215857018..e2d75d6362 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -24,7 +24,8 @@ PREDICATE: writer-method < method-body "writing" word-prop ; [ create-method ] 2dip [ [ props>> ] [ drop ] [ ] tri* update ] [ drop define ] - 3bi ; + [ 2drop make-inline ] + 3tri ; GENERIC# reader-quot 1 ( class slot-spec -- quot ) @@ -41,11 +42,7 @@ M: object reader-quot dup t "reader" set-word-prop ; : reader-props ( slot-spec -- assoc ) - [ - [ "reading" set ] - [ read-only>> [ t "foldable" set ] when ] bi - t "flushable" set - ] H{ } make-assoc ; + "reading" associate ; : define-reader-generic ( name -- ) reader-word (( object -- value )) define-simple-generic ; diff --git a/core/strings/strings.factor b/core/strings/strings.factor index ffcefab78b..8ab0409318 100644 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -37,24 +37,24 @@ M: string hashcode* [ ] [ dup rehash-string string-hashcode ] ?if ; M: string length - length>> ; + length>> ; inline M: string nth-unsafe - [ >fixnum ] dip string-nth ; + [ >fixnum ] dip string-nth ; inline M: string set-nth-unsafe dup reset-string-hashcode - [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; + [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline M: string clone - (clone) [ clone ] change-aux ; + (clone) [ clone ] change-aux ; inline -M: string resize resize-string ; +M: string resize resize-string ; inline : 1string ( ch -- str ) 1 swap ; : >string ( seq -- str ) "" clone-like ; -M: string new-sequence drop 0 ; +M: string new-sequence drop 0 ; inline INSTANCE: string sequence diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 1bdda7b69d..4bbc787294 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -15,10 +15,10 @@ TUPLE: vector M: vector like drop dup vector? [ dup array? [ dup length vector boa ] [ >vector ] if - ] unless ; + ] unless ; inline M: vector new-sequence - drop [ f ] [ >fixnum ] bi vector boa ; + drop [ f ] [ >fixnum ] bi vector boa ; inline M: vector equal? over vector? [ sequence= ] [ 2drop f ] if ; @@ -34,9 +34,9 @@ M: array like 2dup length eq? [ nip ] [ resize-array ] if ] [ >array ] if - ] unless ; + ] unless ; inline -M: sequence new-resizable drop ; +M: sequence new-resizable drop ; inline INSTANCE: vector growable diff --git a/core/words/words.factor b/core/words/words.factor index 2ebdb8b7a8..19a2ce551d 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -12,7 +12,7 @@ IN: words M: word execute (execute) ; -M: word ?execute execute( -- value ) ; +M: word ?execute execute( -- value ) ; inline M: word <=> [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ; @@ -213,7 +213,7 @@ M: word forget* ] if ; M: word hashcode* - nip 1 slot { fixnum } declare ; foldable + nip 1 slot { fixnum } declare ; inline foldable M: word literalize ;