steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2009-08-18 03:45:20 -05:00
parent 761ed6356b 8120bdebea
commit 0cbad41547
42 changed files with 308 additions and 392 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/bit-arrays/bit-arrays.factor
View File

@ -44,33 +44,33 @@ PRIVATE>
: <bit-array> ( n -- bit-array ) : <bit-array> ( n -- bit-array )
dup bits>bytes <byte-array> bit-array boa ; inline dup bits>bytes <byte-array> bit-array boa ; inline
M: bit-array length length>> ; M: bit-array length length>> ; inline
M: bit-array nth-unsafe M: bit-array nth-unsafe
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
M: bit-array set-nth-unsafe M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi* [ >fixnum ] [ underlying>> ] bi*
[ byte/bit set-bit ] 2keep [ 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 -- ) 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 -- ) 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 M: bit-array clone
[ length>> ] [ underlying>> clone ] bi bit-array boa ; [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
: >bit-array ( seq -- bit-array ) : >bit-array ( seq -- bit-array )
T{ bit-array f 0 B{ } } clone-like ; inline 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 <bit-array> ; M: bit-array new-sequence drop <bit-array> ; inline
M: bit-array equal? M: bit-array equal?
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
@ -81,7 +81,7 @@ M: bit-array resize
resize-byte-array resize-byte-array
] 2bi ] 2bi
bit-array boa bit-array boa
dup clean-up ; dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ; M: bit-array byte-length length 7 + -3 shift ;

2
basis/compiler/compiler.factor Normal file → Executable file
View File

@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
} cond ; } cond ;
: optimize? ( word -- ? ) : optimize? ( word -- ? )
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; single-generic? not ;
: contains-breakpoints? ( -- ? ) : contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ; dependencies get keys [ "break?" word-prop ] any? ;

10
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -41,13 +41,13 @@ IN: compiler.tree.cleanup.tests
GENERIC: mynot ( x -- y ) 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 ) GENERIC: detect-f ( x -- y )
M: f detect-f ; M: f detect-f ; inline
[ t ] [ [ t ] [
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined? [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
@ -55,9 +55,9 @@ M: f detect-f ;
GENERIC: xyz ( n -- n ) GENERIC: xyz ( n -- n )
M: integer xyz ; M: integer xyz ; inline
M: object xyz ; M: object xyz ; inline
[ t ] [ [ t ] [
[ { integer } declare xyz ] \ xyz inlined? [ { integer } declare xyz ] \ xyz inlined?

5
basis/compiler/tree/finalization/finalization.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize combinators USING: kernel accessors sequences words memoize combinators
classes classes.builtin classes.tuple math.partial-dispatch classes classes.builtin classes.tuple classes.singleton
fry assocs combinators.short-circuit math.partial-dispatch fry assocs combinators.short-circuit
compiler.tree compiler.tree
compiler.tree.combinators compiler.tree.combinators
compiler.tree.propagation.info compiler.tree.propagation.info
@ -45,6 +45,7 @@ M: predicate finalize-word
"predicating" word-prop { "predicating" word-prop {
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] } { [ dup builtin-class? ] [ drop word>> cached-expansion ] }
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] } { [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
{ [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
[ drop ] [ drop ]
} cond ; } cond ;

2
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -153,7 +153,7 @@ ERROR: uninferable ;
: (value>quot) ( value-info -- quot ) : (value>quot) ( value-info -- quot )
dup class>> { dup class>> {
{ \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] } { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
{ \ curry [ { \ curry [
slots>> third (value>quot) slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ] '[ [ obj>> ] [ quot>> @ ] bi ]

98
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,8 +3,8 @@
USING: accessors kernel arrays sequences math math.order USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.single generic.math math.partial-dispatch generic generic.standard generic.single generic.math
classes.algebra classes.union sets quotations assocs combinators classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart hints combinators.short-circuit words namespaces continuations classes
locals fry hints locals
compiler.tree compiler.tree
compiler.tree.builder compiler.tree.builder
compiler.tree.recursive compiler.tree.recursive
@ -14,19 +14,6 @@ compiler.tree.propagation.info
compiler.tree.propagation.nodes ; compiler.tree.propagation.nodes ;
IN: compiler.tree.propagation.inlining 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 nodes
: splicing-call ( #call word -- nodes ) : splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
@ -101,99 +88,28 @@ M: callable splicing-nodes splicing-body ;
dupd inlining-math-partial eliminate-dispatch ; dupd inlining-math-partial eliminate-dispatch ;
! Method body inlining ! 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 SYMBOL: history
: already-inlined? ( obj -- ? ) history get memq? ; : already-inlined? ( obj -- ? ) history get memq? ;
: add-to-history ( obj -- ) history [ swap suffix ] change ; : add-to-history ( obj -- ) history [ swap suffix ] change ;
: remember-inlining ( word -- )
[ inlining-count get inc-at ]
[ add-to-history ]
bi ;
:: inline-word ( #call word -- ? ) :: inline-word ( #call word -- ? )
word already-inlined? [ f ] [ word already-inlined? [ f ] [
#call word splicing-body [ #call word splicing-body [
[ [
word remember-inlining word add-to-history
[ ] [ count-nodes ] [ (propagate) ] tri dup (propagate)
] with-scope ] with-scope
[ #call (>>body) ] [ node-count +@ ] bi* t #call (>>body) t
] [ f ] if* ] [ f ] if*
] if ; ] if ;
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
: always-inline-word? ( word -- ? ) : always-inline-word? ( word -- ? )
{ curry compose } memq? ; { curry compose } memq? ;
: never-inline-word? ( word -- ? ) : 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 -- ? )
"custom-inlining" word-prop ; "custom-inlining" word-prop ;
@ -217,7 +133,7 @@ SYMBOL: history
{ [ dup always-inline-word? ] [ inline-word ] } { [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] } { [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] } { [ dup math-generic? ] [ inline-math-method ] }
{ [ dup method-body? ] [ inline-method-body ] } { [ dup inline? ] [ inline-word ] }
[ 2drop f ] [ 2drop f ]
} cond ; } cond ;

23
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -56,9 +56,9 @@ IN: compiler.tree.propagation.tests
[ float ] [ [ { float real } declare + ] final-math-class ] unit-test [ 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 [ 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 ] final-classes
] unit-test ] unit-test
[ V{ f { } } ] [
[
T{ mixed-mutable-immutable f 3 { } }
[ x>> ] [ y>> ] bi
] final-literals
] unit-test
! Recursive propagation ! Recursive propagation
: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive : 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 ] unit-test
GENERIC: iterate ( obj -- next-obj ? ) GENERIC: iterate ( obj -- next-obj ? )
M: fixnum iterate f ; M: fixnum iterate f ; inline
M: array iterate first t ; M: array iterate first t ; inline
: dead-loop ( obj -- final-obj ) : dead-loop ( obj -- final-obj )
iterate [ dead-loop ] when ; inline recursive iterate [ dead-loop ] when ; inline recursive
@ -567,7 +574,7 @@ M: array iterate first t ;
] unit-test ] unit-test
GENERIC: bad-generic ( a -- b ) 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 : bad-behavior ( -- b ) 4 bad-generic ; inline recursive
[ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
@ -740,7 +747,7 @@ TUPLE: foo bar ;
[ t ] [ [ foo new ] { new } inlined? ] unit-test [ t ] [ [ foo new ] { new } inlined? ] unit-test
GENERIC: whatever ( x -- y ) GENERIC: whatever ( x -- y )
M: number whatever drop foo ; M: number whatever drop foo ; inline
[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test [ 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 [ f ] [ [ that-thing new ] { new } inlined? ] unit-test
GENERIC: whatever2 ( x -- y ) GENERIC: whatever2 ( x -- y )
M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
M: f whatever2 ; M: f whatever2 ; inline
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test [ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test

2
basis/compiler/tree/propagation/propagation.factor
View File

@ -19,6 +19,4 @@ IN: compiler.tree.propagation
H{ } clone copies set H{ } clone copies set
H{ } clone 1array value-infos set H{ } clone 1array value-infos set
H{ } clone 1array constraints set H{ } clone 1array constraints set
H{ } clone inlining-count set
dup compute-node-count
dup (propagate) ; dup (propagate) ;

20
basis/grouping/grouping.factor
View File

@ -18,41 +18,41 @@ GENERIC: group@ ( n groups -- from to seq )
M: chunking-seq set-nth group@ <slice> 0 swap copy ; M: chunking-seq set-nth group@ <slice> 0 swap copy ;
M: chunking-seq like drop { } like ; M: chunking-seq like drop { } like ; inline
INSTANCE: chunking-seq sequence INSTANCE: chunking-seq sequence
MIXIN: subseq-chunking MIXIN: subseq-chunking
M: subseq-chunking nth group@ subseq ; M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking MIXIN: slice-chunking
M: slice-chunking nth group@ <slice> ; M: slice-chunking nth group@ <slice> ; inline
M: slice-chunking nth-unsafe group@ slice boa ; M: slice-chunking nth-unsafe group@ slice boa ; inline
TUPLE: abstract-groups < chunking-seq ; TUPLE: abstract-groups < chunking-seq ;
M: abstract-groups length M: abstract-groups length
[ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
M: abstract-groups set-length M: abstract-groups set-length
[ n>> * ] [ seq>> ] bi set-length ; [ n>> * ] [ seq>> ] bi set-length ; inline
M: abstract-groups group@ 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 ; TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length M: abstract-clumps length
[ seq>> length ] [ n>> ] bi - 1 + ; [ seq>> length ] [ n>> ] bi - 1 + ; inline
M: abstract-clumps set-length M: abstract-clumps set-length
[ n>> + 1 - ] [ seq>> ] bi set-length ; [ n>> + 1 - ] [ seq>> ] bi set-length ; inline
M: abstract-clumps group@ M: abstract-clumps group@
[ n>> over + ] [ seq>> ] bi ; [ n>> over + ] [ seq>> ] bi ; inline
PRIVATE> PRIVATE>

4
basis/io/encodings/ascii/ascii.factor
View File

@ -16,7 +16,7 @@ PRIVATE>
SINGLETON: ascii SINGLETON: ascii
M: ascii encode-char M: ascii encode-char
128 encode-if< ; 128 encode-if< ; inline
M: ascii decode-char M: ascii decode-char
128 decode-if< ; 128 decode-if< ; inline

4
basis/math/bits/bits.factor
View File

@ -9,9 +9,9 @@ C: <bits> bits
: make-bits ( number -- bits ) : make-bits ( number -- bits )
[ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if-zero ; inline [ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] 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 INSTANCE: bits immutable-sequence

32
basis/math/complex/complex.factor
View File

@ -5,29 +5,29 @@ math.libm math.functions arrays math.functions.private sequences
parser ; parser ;
IN: math.complex.private IN: math.complex.private
M: real real-part ; M: real real-part ; inline
M: real imaginary-part drop 0 ; M: real imaginary-part drop 0 ; inline
M: complex real-part real>> ; M: complex real-part real>> ; inline
M: complex imaginary-part imaginary>> ; M: complex imaginary-part imaginary>> ; inline
M: complex absq >rect [ sq ] bi@ + ; M: complex absq >rect [ sq ] bi@ + ; inline
M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline
: componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline : componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline
: complex= ( x y quot -- ? ) componentwise and ; inline : complex= ( x y quot -- ? ) componentwise and ; inline
M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline
M: complex number= [ number= ] complex= ; M: complex number= [ number= ] complex= ; inline
: complex-op ( x y quot -- z ) componentwise rect> ; inline : complex-op ( x y quot -- z ) componentwise rect> ; inline
M: complex + [ + ] complex-op ; M: complex + [ + ] complex-op ; inline
M: complex - [ - ] complex-op ; M: complex - [ - ] complex-op ; inline
: *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; 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 : *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 -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline : complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline
M: complex / [ / ] complex/ ; M: complex / [ / ] complex/ ; inline
M: complex /f [ /f ] complex/ ; M: complex /f [ /f ] complex/ ; inline
M: complex /i [ /i ] complex/ ; M: complex /i [ /i ] complex/ ; inline
M: complex abs absq >float fsqrt ; M: complex abs absq >float fsqrt ; inline
M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
IN: syntax IN: syntax

22
basis/math/functions/functions.factor
View File

@ -13,7 +13,7 @@ IN: math.functions
GENERIC: sqrt ( x -- y ) foldable GENERIC: sqrt ( x -- y ) foldable
M: real sqrt 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-2s ( n -- r s )
#! factor an integer into 2^r * s #! factor an integer into 2^r * s
@ -120,7 +120,7 @@ ERROR: non-trivial-divisor n ;
GENERIC: absq ( x -- y ) foldable GENERIC: absq ( x -- y ) foldable
M: real absq sq ; M: real absq sq ; inline
: ~abs ( x y epsilon -- ? ) : ~abs ( x y epsilon -- ? )
[ - abs ] dip < ; [ - abs ] dip < ;
@ -148,13 +148,13 @@ M: real absq sq ;
GENERIC: exp ( x -- y ) GENERIC: exp ( x -- y )
M: real exp fexp ; M: real exp fexp ; inline
M: complex exp >rect swap fexp swap polar> ; M: complex exp >rect swap fexp swap polar> ;
GENERIC: log ( x -- y ) 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> ; M: complex log >polar swap flog swap rect> ;
@ -169,7 +169,7 @@ M: complex cos
[ [ fcos ] [ fcosh ] bi* * ] [ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ; [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
M: real cos fcos ; M: real cos fcos ; inline
: sec ( x -- y ) cos recip ; inline : sec ( x -- y ) cos recip ; inline
@ -180,7 +180,7 @@ M: complex cosh
[ [ fcosh ] [ fcos ] bi* * ] [ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ; [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
M: real cosh fcosh ; M: real cosh fcosh ; inline
: sech ( x -- y ) cosh recip ; inline : sech ( x -- y ) cosh recip ; inline
@ -191,7 +191,7 @@ M: complex sin
[ [ fsin ] [ fcosh ] bi* * ] [ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ; [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
M: real sin fsin ; M: real sin fsin ; inline
: cosec ( x -- y ) sin recip ; inline : cosec ( x -- y ) sin recip ; inline
@ -202,7 +202,7 @@ M: complex sinh
[ [ fsinh ] [ fcos ] bi* * ] [ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ; [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
M: real sinh fsinh ; M: real sinh fsinh ; inline
: cosech ( x -- y ) sinh recip ; inline : cosech ( x -- y ) sinh recip ; inline
@ -210,13 +210,13 @@ GENERIC: tan ( x -- y ) foldable
M: complex tan [ sin ] [ cos ] bi / ; M: complex tan [ sin ] [ cos ] bi / ;
M: real tan ftan ; M: real tan ftan ; inline
GENERIC: tanh ( x -- y ) foldable GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ; M: complex tanh [ sinh ] [ cosh ] bi / ;
M: real tanh ftanh ; M: real tanh ftanh ; inline
: cot ( x -- y ) tan recip ; inline : cot ( x -- y ) tan recip ; inline
@ -252,7 +252,7 @@ GENERIC: atan ( x -- y ) foldable
M: complex atan i* atanh i* ; M: complex atan i* atanh i* ;
M: real atan fatan ; M: real atan fatan ; inline
: asec ( x -- y ) recip acos ; inline : asec ( x -- y ) recip acos ; inline

6
basis/math/ranges/ranges.factor
View File

@ -12,11 +12,9 @@ TUPLE: range
: <range> ( a b step -- range ) : <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 ) M: range length ( seq -- n ) length>> ; inline
length>> ;
M: range nth-unsafe ( n range -- obj ) M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
[ step>> * ] keep from>> + ;
! For ranges with many elements, the default element-wise methods ! For ranges with many elements, the default element-wise methods
! sequences define are unsuitable because they're O(n) ! sequences define are unsuitable because they're O(n)

4
basis/math/ratios/ratios.factor
View File

@ -48,8 +48,8 @@ M: ratio >fixnum >fraction /i >fixnum ;
M: ratio >bignum >fraction /i >bignum ; M: ratio >bignum >fraction /i >bignum ;
M: ratio >float >fraction /f ; M: ratio >float >fraction /f ;
M: ratio numerator numerator>> ; M: ratio numerator numerator>> ; inline
M: ratio denominator denominator>> ; M: ratio denominator denominator>> ; inline
M: ratio < scale < ; M: ratio < scale < ;
M: ratio <= scale <= ; M: ratio <= scale <= ;

2
basis/stack-checker/known-words/known-words.factor
View File

@ -158,6 +158,8 @@ M: bad-executable summary
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop \ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
\ <tuple-boa> t "flushable" set-word-prop
: infer-effect-unsafe ( word -- ) : infer-effect-unsafe ( word -- )
pop-literal nip pop-literal nip
add-effect-input add-effect-input

10
basis/tuple-arrays/tuple-arrays.factor
View File

@ -54,17 +54,17 @@ TUPLE: CLASS-array
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep [ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
\ CLASS-array boa ; inline \ 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 <CLASS-array> ; M: CLASS-array new-sequence drop <CLASS-array> ; inline
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ; : >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> 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 INSTANCE: CLASS-array sequence

6
basis/vectors/functor/functor.factor
View File

@ -18,11 +18,11 @@ TUPLE: V { underlying A } { length array-capacity } ;
M: V like M: V like
drop dup V instance? [ drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V ] if dup A instance? [ dup length V boa ] [ >V ] if
] unless ; ] unless ; inline
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ; M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ; inline
M: A new-resizable drop <V> ; M: A new-resizable drop <V> ; inline
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;

9
basis/windows/ole32/ole32.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.syntax alien.c-types alien.strings math 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 accessors math.order namespaces make math.parser windows.kernel32
combinators locals specialized-arrays.direct.uchar ; combinators locals specialized-arrays.direct.uchar ;
IN: windows.ole32 IN: windows.ole32
@ -116,11 +116,10 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? ) : succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ; 0 HEX: 7FFFFFFF between? ;
TUPLE: ole32-error error-code ; TUPLE: ole32-error code message ;
C: <ole32-error> ole32-error
M: ole32-error error. : <ole32-error> ( code -- error )
"COM method failed: " print error-code>> n>win32-error-string print ; dup n>win32-error-string \ ole32-error boa ;
: ole32-error ( hresult -- ) : ole32-error ( hresult -- )
dup succeeded? [ drop ] [ <ole32-error> throw ] if ; dup succeeded? [ drop ] [ <ole32-error> throw ] if ;

4
core/alien/alien.factor
View File

@ -20,11 +20,11 @@ UNION: pinned-c-ptr
GENERIC: >c-ptr ( obj -- c-ptr ) GENERIC: >c-ptr ( obj -- c-ptr )
M: c-ptr >c-ptr ; M: c-ptr >c-ptr ; inline
SLOT: underlying SLOT: underlying
M: object >c-ptr underlying>> ; M: object >c-ptr underlying>> ; inline
GENERIC: expired? ( c-ptr -- ? ) flushable GENERIC: expired? ( c-ptr -- ? ) flushable

14
core/arrays/arrays.factor
View File

@ -4,17 +4,17 @@ USING: accessors kernel kernel.private math math.private
sequences sequences.private ; sequences sequences.private ;
IN: arrays IN: arrays
M: array clone (clone) ; M: array clone (clone) ; inline
M: array length length>> ; M: array length length>> ; inline
M: array nth-unsafe [ >fixnum ] dip array-nth ; M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
M: array resize resize-array ; M: array resize resize-array ; inline
: >array ( seq -- array ) { } clone-like ; : >array ( seq -- array ) { } clone-like ;
M: object new-sequence drop 0 <array> ; M: object new-sequence drop 0 <array> ; inline
M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
M: array equal? M: array equal?
over array? [ sequence= ] [ 2drop f ] if ; over array? [ sequence= ] [ 2drop f ] if ;

34
core/assocs/assocs.factor
View File

@ -17,7 +17,7 @@ GENERIC: assoc-like ( assoc exemplar -- newassoc )
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc ) GENERIC: >alist ( assoc -- newassoc )
M: assoc assoc-like drop ; M: assoc assoc-like drop ; inline
: ?at ( key assoc -- value/key ? ) : ?at ( key assoc -- value/key ? )
2dup at* [ 2nip t ] [ 2drop f ] if ; inline 2dup at* [ 2nip t ] [ 2drop f ] if ; inline
@ -87,7 +87,7 @@ PRIVATE>
M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ dup assoc-size ] dip new-assoc [ dup assoc-size ] dip new-assoc
[ [ set-at ] with-assoc assoc-each ] keep ; [ [ set-at ] with-assoc assoc-each ] keep ; inline
: keys ( assoc -- keys ) : keys ( assoc -- keys )
[ drop ] { } assoc>map ; [ drop ] { } assoc>map ;
@ -189,48 +189,48 @@ M: sequence set-at
[ 2nip set-second ] [ 2nip set-second ]
[ drop [ swap 2array ] dip push ] if ; [ drop [ swap 2array ] dip push ] if ;
M: sequence new-assoc drop <vector> ; M: sequence new-assoc drop <vector> ; inline
M: sequence clear-assoc delete-all ; M: sequence clear-assoc delete-all ; inline
M: sequence delete-at M: sequence delete-at
[ nip ] [ search-alist nip ] 2bi [ nip ] [ search-alist nip ] 2bi
[ swap delete-nth ] [ drop ] if* ; [ swap delete-nth ] [ drop ] if* ;
M: sequence assoc-size length ; M: sequence assoc-size length ; inline
M: sequence assoc-clone-like M: sequence assoc-clone-like
[ >alist ] dip clone-like ; [ >alist ] dip clone-like ; inline
M: sequence assoc-like M: sequence assoc-like
[ >alist ] dip like ; [ >alist ] dip like ; inline
M: sequence >alist ; M: sequence >alist ; inline
! Override sequence => assoc instance for f ! 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 INSTANCE: sequence assoc
TUPLE: enum seq ; TUPLE: enum { seq read-only } ;
C: <enum> enum C: <enum> enum
M: enum at* M: enum at*
seq>> 2dup bounds-check? 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 ) 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 INSTANCE: enum assoc

12
core/byte-arrays/byte-arrays.factor
View File

@ -4,18 +4,18 @@ USING: accessors kernel kernel.private alien.accessors sequences
sequences.private math ; sequences.private math ;
IN: byte-arrays IN: byte-arrays
M: byte-array clone (clone) ; M: byte-array clone (clone) ; inline
M: byte-array length length>> ; M: byte-array length length>> ; inline
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline
: >byte-array ( seq -- byte-array ) B{ } clone-like ; 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? M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ; over byte-array? [ sequence= ] [ 2drop f ] if ;
M: byte-array resize M: byte-array resize
resize-byte-array ; resize-byte-array ; inline
INSTANCE: byte-array sequence INSTANCE: byte-array sequence

10
core/byte-vectors/byte-vectors.factor
View File

@ -18,15 +18,15 @@ M: byte-vector like
drop dup byte-vector? [ drop dup byte-vector? [
dup byte-array? dup byte-array?
[ dup length byte-vector boa ] [ >byte-vector ] if [ dup length byte-vector boa ] [ >byte-vector ] if
] unless ; ] unless ; inline
M: byte-vector new-sequence 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? M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ; over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-vector contract 2drop ; M: byte-vector contract 2drop ; inline
M: byte-array like M: byte-array like
#! If we have an byte-array, we're done. #! If we have an byte-array, we're done.
@ -39,8 +39,8 @@ M: byte-array like
2dup length eq? 2dup length eq?
[ nip ] [ resize-byte-array ] if [ nip ] [ resize-byte-array ] if
] [ >byte-array ] if ] [ >byte-array ] if
] unless ; ] unless ; inline
M: byte-array new-resizable drop <byte-vector> ; M: byte-array new-resizable drop <byte-vector> ; inline
INSTANCE: byte-vector growable INSTANCE: byte-vector growable

4
core/classes/builtin/builtin.factor
View File

@ -20,9 +20,9 @@ PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
: bootstrap-type>class ( n -- class ) builtins get nth ; : 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 ; M: builtin-class rank-class drop 0 ;

4
core/classes/tuple/tuple.factor
View File

@ -29,7 +29,7 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
: layout-of ( tuple -- layout ) : layout-of ( tuple -- layout )
1 slot { array } declare ; inline 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 ) : tuple-size ( tuple -- size )
layout-of 3 slot { fixnum } declare ; inline layout-of 3 slot { fixnum } declare ; inline
@ -323,7 +323,7 @@ M: tuple-class (classes-intersect?)
[ swap classes-intersect? ] [ swap classes-intersect? ]
} cond ; } cond ;
M: tuple clone (clone) ; M: tuple clone (clone) ; inline
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;

14
core/growable/growable.factor
View File

@ -9,9 +9,9 @@ MIXIN: growable
SLOT: length SLOT: length
SLOT: underlying SLOT: underlying
M: growable length length>> ; M: growable length length>> ; inline
M: growable nth-unsafe underlying>> nth-unsafe ; M: growable nth-unsafe underlying>> nth-unsafe ; inline
M: growable set-nth-unsafe underlying>> set-nth-unsafe ; M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
: capacity ( seq -- n ) underlying>> length ; inline : capacity ( seq -- n ) underlying>> length ; inline
@ -49,21 +49,21 @@ M: growable set-length ( n seq -- )
[ >fixnum ] dip [ >fixnum ] dip
] if ; inline ] 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 -- ) M: growable lengthen ( n seq -- )
2dup length > [ 2dup length > [
2dup capacity > [ over new-size over expand ] when 2dup capacity > [ over new-size over expand ] when
2dup (>>length) 2dup (>>length)
] when 2drop ; ] when 2drop ; inline
M: growable shorten ( n seq -- ) M: growable shorten ( n seq -- )
growable-check growable-check
2dup length < [ 2dup length < [
2dup contract 2dup contract
2dup (>>length) 2dup (>>length)
] when 2drop ; ] when 2drop ; inline
INSTANCE: growable sequence INSTANCE: growable sequence

10
core/hashtables/hashtables.factor
View File

@ -112,7 +112,7 @@ M: hashtable delete-at ( key hash -- )
] if ; ] if ;
M: hashtable assoc-size ( hash -- n ) M: hashtable assoc-size ( hash -- n )
[ count>> ] [ deleted>> ] bi - ; [ count>> ] [ deleted>> ] bi - ; inline
: rehash ( hash -- ) : rehash ( hash -- )
dup >alist [ dup >alist [
@ -150,7 +150,7 @@ M: hashtable >alist
] keep { } like ; ] keep { } like ;
M: hashtable clone M: hashtable clone
(clone) [ clone ] change-array ; (clone) [ clone ] change-array ; inline
M: hashtable equal? M: hashtable equal?
over hashtable? [ over hashtable? [
@ -159,15 +159,15 @@ M: hashtable equal?
] [ 2drop f ] if ; ] [ 2drop f ] if ;
! Default method ! Default method
M: assoc new-assoc drop <hashtable> ; M: assoc new-assoc drop <hashtable> ; inline
M: f new-assoc drop <hashtable> ; M: f new-assoc drop <hashtable> ; inline
: >hashtable ( assoc -- hashtable ) : >hashtable ( assoc -- hashtable )
H{ } assoc-clone-like ; H{ } assoc-clone-like ;
M: hashtable assoc-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 ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ; [ [ set-at ] keep ] [ associate ] if* ;

2
core/io/encodings/utf8/utf8.factor
View File

@ -40,7 +40,7 @@ SINGLETON: utf8
dup stream-read1 dup [ begin-utf8 ] when nip ; inline dup stream-read1 dup [ begin-utf8 ] when nip ; inline
M: utf8 decode-char M: utf8 decode-char
drop decode-utf8 ; drop decode-utf8 ; inline
! Encoding UTF-8 ! Encoding UTF-8

12
core/kernel/kernel.factor
View File

@ -192,19 +192,19 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
! Object protocol ! Object protocol
GENERIC: hashcode* ( depth obj -- code ) 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 : hashcode ( obj -- code ) 3 swap hashcode* ; inline
GENERIC: equal? ( obj1 obj2 -- ? ) GENERIC: equal? ( obj1 obj2 -- ? )
M: object equal? 2drop f ; M: object equal? 2drop f ; inline
TUPLE: identity-tuple ; TUPLE: identity-tuple ;
M: identity-tuple equal? 2drop f ; M: identity-tuple equal? 2drop f ; inline
: = ( obj1 obj2 -- ? ) : = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ 2dup eq? [ 2drop t ] [
@ -213,9 +213,9 @@ M: identity-tuple equal? 2drop f ;
GENERIC: clone ( obj -- cloned ) GENERIC: clone ( obj -- cloned )
M: object clone ; M: object clone ; inline
M: callstack clone (clone) ; M: callstack clone (clone) ; inline
! Tuple construction ! Tuple construction
GENERIC: new ( class -- tuple ) GENERIC: new ( class -- tuple )

2
core/layouts/layouts.factor
View File

@ -78,6 +78,6 @@ M: bignum >integer
M: real >integer M: real >integer
dup most-negative-fixnum most-positive-fixnum between? dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] [ >bignum ] if ; [ >fixnum ] [ >bignum ] if ; inline
UNION: immediate fixnum POSTPONE: f ; UNION: immediate fixnum POSTPONE: f ;

8
core/math/floats/floats-docs.factor
View File

@ -10,21 +10,21 @@ HELP: >float
HELP: bits>double ( n -- x ) HELP: bits>double ( n -- x )
{ $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } } { $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 { bits>double bits>float double>bits float>bits } related-words
HELP: bits>float ( n -- x ) HELP: bits>float ( n -- x )
{ $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } } { $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 ) HELP: double>bits ( x -- n )
{ $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } } { $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 ) HELP: float>bits ( x -- n )
{ $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } } { $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 ! Unsafe primitives
HELP: float+ ( x y -- z ) HELP: float+ ( x y -- z )

40
core/math/floats/floats.factor
View File

@ -3,28 +3,28 @@
USING: kernel math math.private ; USING: kernel math math.private ;
IN: math.floats.private IN: math.floats.private
M: fixnum >float fixnum>float ; M: fixnum >float fixnum>float ; inline
M: bignum >float bignum>float ; M: bignum >float bignum>float ; inline
M: float >fixnum float>fixnum ; M: float >fixnum float>fixnum ; inline
M: float >bignum float>bignum ; M: float >bignum float>bignum ; inline
M: float >float ; M: float >float ; inline
M: float hashcode* nip float>bits ; M: float hashcode* nip float>bits ; inline
M: float equal? over float? [ float= ] [ 2drop f ] if ; M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
M: float number= float= ; M: float number= float= ; inline
M: float < float< ; M: float < float< ; inline
M: float <= float<= ; M: float <= float<= ; inline
M: float > float> ; M: float > float> ; inline
M: float >= float>= ; M: float >= float>= ; inline
M: float + float+ ; M: float + float+ ; inline
M: float - float- ; M: float - float- ; inline
M: float * float* ; M: float * float* ; inline
M: float / float/f ; M: float / float/f ; inline
M: float /f float/f ; M: float /f float/f ; inline
M: float /i float/f >integer ; M: float /i float/f >integer ; inline
M: float mod float-mod ; M: float mod float-mod ; inline
M: real abs dup 0 < [ neg ] when ; M: real abs dup 0 < [ neg ] when ; inline

94
core/math/integers/integers.factor
View File

@ -5,79 +5,79 @@ USING: kernel kernel.private sequences
sequences.private math math.private combinators ; sequences.private math math.private combinators ;
IN: math.integers.private IN: math.integers.private
M: integer numerator ; M: integer numerator ; inline
M: integer denominator drop 1 ; M: integer denominator drop 1 ; inline
M: fixnum >fixnum ; M: fixnum >fixnum ; inline
M: fixnum >bignum fixnum>bignum ; M: fixnum >bignum fixnum>bignum ; inline
M: fixnum >integer ; M: fixnum >integer ; inline
M: fixnum hashcode* nip ; M: fixnum hashcode* nip ; inline
M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
M: fixnum number= eq? ; M: fixnum number= eq? ; inline
M: fixnum < fixnum< ; M: fixnum < fixnum< ; inline
M: fixnum <= fixnum<= ; M: fixnum <= fixnum<= ; inline
M: fixnum > fixnum> ; M: fixnum > fixnum> ; inline
M: fixnum >= fixnum>= ; M: fixnum >= fixnum>= ; inline
M: fixnum + fixnum+ ; M: fixnum + fixnum+ ; inline
M: fixnum - fixnum- ; M: fixnum - fixnum- ; inline
M: fixnum * fixnum* ; M: fixnum * fixnum* ; inline
M: fixnum /i fixnum/i ; M: fixnum /i fixnum/i ; inline
M: fixnum /f [ >float ] dip >float float/f ; 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 bitand fixnum-bitand ; inline
M: fixnum bitor fixnum-bitor ; M: fixnum bitor fixnum-bitor ; inline
M: fixnum bitxor fixnum-bitxor ; M: fixnum bitxor fixnum-bitxor ; inline
M: fixnum shift >fixnum fixnum-shift ; 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 ) : fixnum-log2 ( x -- n )
0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ; 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 >fixnum bignum>fixnum ; inline
M: bignum >bignum ; M: bignum >bignum ; inline
M: bignum hashcode* nip >fixnum ; M: bignum hashcode* nip >fixnum ;
M: bignum equal? M: bignum equal?
over bignum? [ bignum= ] [ over bignum? [ bignum= ] [
swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if 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< ; inline
M: bignum <= bignum<= ; M: bignum <= bignum<= ; inline
M: bignum > bignum> ; M: bignum > bignum> ; inline
M: bignum >= bignum>= ; M: bignum >= bignum>= ; inline
M: bignum + bignum+ ; M: bignum + bignum+ ; inline
M: bignum - bignum- ; M: bignum - bignum- ; inline
M: bignum * bignum* ; M: bignum * bignum* ; inline
M: bignum /i bignum/i ; M: bignum /i bignum/i ; inline
M: bignum mod bignum-mod ; M: bignum mod bignum-mod ; inline
M: bignum /mod bignum/mod ; M: bignum /mod bignum/mod ; inline
M: bignum bitand bignum-bitand ; M: bignum bitand bignum-bitand ; inline
M: bignum bitor bignum-bitor ; M: bignum bitor bignum-bitor ; inline
M: bignum bitxor bignum-bitxor ; M: bignum bitxor bignum-bitxor ; inline
M: bignum shift >fixnum bignum-shift ; M: bignum shift >fixnum bignum-shift ; inline
M: bignum bitnot bignum-bitnot ; M: bignum bitnot bignum-bitnot ; inline
M: bignum bit? bignum-bit? ; M: bignum bit? bignum-bit? ; inline
M: bignum (log2) bignum-log2 ; M: bignum (log2) bignum-log2 ; inline
! Converting ratios to floats. Based on FLOAT-RATIO from ! Converting ratios to floats. Based on FLOAT-RATIO from
! sbcl/src/code/float.lisp, which has the following license: ! sbcl/src/code/float.lisp, which has the following license:

30
core/math/math.factor
View File

@ -98,38 +98,38 @@ GENERIC: fp-infinity? ( x -- ? )
GENERIC: fp-nan-payload ( x -- bits ) GENERIC: fp-nan-payload ( x -- bits )
M: object fp-special? M: object fp-special?
drop f ; drop f ; inline
M: object fp-nan? M: object fp-nan?
drop f ; drop f ; inline
M: object fp-qnan? M: object fp-qnan?
drop f ; drop f ; inline
M: object fp-snan? M: object fp-snan?
drop f ; drop f ; inline
M: object fp-infinity? M: object fp-infinity?
drop f ; drop f ; inline
M: object fp-nan-payload M: object fp-nan-payload
drop f ; drop f ; inline
M: float fp-special? 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 M: float fp-nan-payload
double>bits HEX: fffffffffffff bitand ; foldable flushable double>bits HEX: fffffffffffff bitand ; inline
M: float fp-nan? 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? 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? 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? 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
: <fp-nan> ( payload -- nan ) : <fp-nan> ( payload -- nan )
HEX: 7ff0000000000000 bitor bits>double ; foldable flushable HEX: 7ff0000000000000 bitor bits>double ; inline
: next-float ( m -- n ) : next-float ( m -- n )
double>bits double>bits
@ -137,7 +137,7 @@ M: float fp-infinity?
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
1 + bits>double ! positive 1 + bits>double ! positive
] if ] if
] if ; foldable flushable ] if ; inline
: prev-float ( m -- n ) : prev-float ( m -- n )
double>bits double>bits
@ -145,7 +145,7 @@ M: float fp-infinity?
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
1 - bits>double ! positive non-zero 1 - bits>double ! positive non-zero
] if ] if
] if ; foldable flushable ] if ; inline
: next-power-of-2 ( m -- n ) : next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline

20
core/math/order/order.factor
View File

@ -15,24 +15,24 @@ GENERIC: <=> ( obj1 obj2 -- <=> )
: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline : >=< ( 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: before? ( obj1 obj2 -- ? )
GENERIC: after? ( obj1 obj2 -- ? ) GENERIC: after? ( obj1 obj2 -- ? )
GENERIC: before=? ( obj1 obj2 -- ? ) GENERIC: before=? ( obj1 obj2 -- ? )
GENERIC: after=? ( obj1 obj2 -- ? ) GENERIC: after=? ( obj1 obj2 -- ? )
M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline
M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline
M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline
M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline
M: real before? ( obj1 obj2 -- ? ) < ; M: real before? ( obj1 obj2 -- ? ) < ; inline
M: real after? ( obj1 obj2 -- ? ) > ; M: real after? ( obj1 obj2 -- ? ) > ; inline
M: real before=? ( obj1 obj2 -- ? ) <= ; M: real before=? ( obj1 obj2 -- ? ) <= ; inline
M: real after=? ( obj1 obj2 -- ? ) >= ; 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 : max ( x y -- z ) [ after? ] most ; inline
: clamp ( x min max -- y ) [ max ] dip min ; inline : clamp ( x min max -- y ) [ max ] dip min ; inline

12
core/sbufs/sbufs.factor
View File

@ -11,24 +11,24 @@ TUPLE: sbuf
: <sbuf> ( n -- sbuf ) 0 <string> 0 sbuf boa ; inline : <sbuf> ( n -- sbuf ) 0 <string> 0 sbuf boa ; inline
M: sbuf set-nth-unsafe M: sbuf set-nth-unsafe
[ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline
M: sbuf new-sequence M: sbuf new-sequence
drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ; drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ; inline
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
M: sbuf like M: sbuf like
drop dup sbuf? [ drop dup sbuf? [
dup string? [ dup length sbuf boa ] [ >sbuf ] if dup string? [ dup length sbuf boa ] [ >sbuf ] if
] unless ; ] unless ; inline
M: sbuf new-resizable drop <sbuf> ; M: sbuf new-resizable drop <sbuf> ; inline
M: sbuf equal? M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ; over sbuf? [ sequence= ] [ 2drop f ] if ;
M: string new-resizable drop <sbuf> ; M: string new-resizable drop <sbuf> ; inline
M: string like M: string like
#! If we have a string, we're done. #! If we have a string, we're done.
@ -41,6 +41,6 @@ M: string like
2dup length eq? 2dup length eq?
[ nip dup reset-string-hashcode ] [ resize-string ] if [ nip dup reset-string-hashcode ] [ resize-string ] if
] [ >string ] if ] [ >string ] if
] unless ; ] unless ; inline
INSTANCE: sbuf growable INSTANCE: sbuf growable

62
core/sequences/sequences.factor
View File

@ -18,14 +18,14 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq ) : new-like ( len exemplar quot -- seq )
over [ [ new-sequence ] dip call ] dip like ; inline over [ [ new-sequence ] dip call ] dip like ; inline
M: sequence like drop ; M: sequence like drop ; inline
GENERIC: lengthen ( n seq -- ) GENERIC: lengthen ( n seq -- )
GENERIC: shorten ( 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 : empty? ( seq -- ? ) length 0 = ; inline
@ -82,25 +82,25 @@ GENERIC: resize ( n seq -- newseq ) flushable
GENERIC: nth-unsafe ( n seq -- elt ) flushable GENERIC: nth-unsafe ( n seq -- elt ) flushable
GENERIC: set-nth-unsafe ( elt n seq -- ) GENERIC: set-nth-unsafe ( elt n seq -- )
M: sequence nth bounds-check nth-unsafe ; M: sequence nth bounds-check nth-unsafe ; inline
M: sequence set-nth bounds-check set-nth-unsafe ; M: sequence set-nth bounds-check set-nth-unsafe ; inline
M: sequence nth-unsafe nth ; M: sequence nth-unsafe nth ; inline
M: sequence set-nth-unsafe set-nth ; M: sequence set-nth-unsafe set-nth ; inline
: change-nth-unsafe ( i seq quot -- ) : change-nth-unsafe ( i seq quot -- )
[ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
! The f object supports the sequence protocol trivially ! The f object supports the sequence protocol trivially
M: f length drop 0 ; M: f length drop 0 ; inline
M: f nth-unsafe nip ; M: f nth-unsafe nip ; inline
M: f like drop [ f ] when-empty ; M: f like drop [ f ] when-empty ; inline
INSTANCE: f immutable-sequence INSTANCE: f immutable-sequence
! Integers support the sequence protocol ! Integers support the sequence protocol
M: integer length ; M: integer length ; inline
M: integer nth-unsafe drop ; M: integer nth-unsafe drop ; inline
INSTANCE: integer immutable-sequence INSTANCE: integer immutable-sequence
@ -113,8 +113,8 @@ TUPLE: iota { n integer read-only } ;
<PRIVATE <PRIVATE
M: iota length n>> ; M: iota length n>> ; inline
M: iota nth-unsafe drop ; M: iota nth-unsafe drop ; inline
INSTANCE: iota immutable-sequence INSTANCE: iota immutable-sequence
@ -185,12 +185,12 @@ MIXIN: virtual-sequence
GENERIC: virtual-seq ( seq -- seq' ) GENERIC: virtual-seq ( seq -- seq' )
GENERIC: virtual@ ( n seq -- n' seq' ) GENERIC: virtual@ ( n seq -- n' seq' )
M: virtual-sequence nth virtual@ nth ; M: virtual-sequence nth virtual@ nth ; inline
M: virtual-sequence set-nth virtual@ set-nth ; M: virtual-sequence set-nth virtual@ set-nth ; inline
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline
M: virtual-sequence like virtual-seq like ; M: virtual-sequence like virtual-seq like ; inline
M: virtual-sequence new-sequence virtual-seq new-sequence ; M: virtual-sequence new-sequence virtual-seq new-sequence ; inline
INSTANCE: virtual-sequence sequence INSTANCE: virtual-sequence sequence
@ -199,11 +199,9 @@ TUPLE: reversed { seq read-only } ;
C: <reversed> reversed C: <reversed> reversed
M: reversed virtual-seq seq>> ; M: reversed virtual-seq seq>> ; inline
M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline
M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; M: reversed length seq>> length ; inline
M: reversed length seq>> length ;
INSTANCE: reversed virtual-sequence INSTANCE: reversed virtual-sequence
@ -233,11 +231,11 @@ TUPLE: slice-error from to seq reason ;
check-slice check-slice
slice boa ; inline 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 : short ( seq n -- seq n' ) over length min ; inline
@ -260,8 +258,8 @@ TUPLE: repetition { len read-only } { elt read-only } ;
C: <repetition> repetition C: <repetition> repetition
M: repetition length len>> ; M: repetition length len>> ; inline
M: repetition nth-unsafe nip elt>> ; M: repetition nth-unsafe nip elt>> ; inline
INSTANCE: repetition immutable-sequence INSTANCE: repetition immutable-sequence
@ -316,9 +314,9 @@ PRIVATE>
(copy) drop ; inline (copy) drop ; inline
M: sequence clone-like 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 ; : push-all ( src dest -- ) [ length ] [ copy ] bi ;

9
core/slots/slots.factor
View File

@ -24,7 +24,8 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
[ create-method ] 2dip [ create-method ] 2dip
[ [ props>> ] [ drop ] [ ] tri* update ] [ [ props>> ] [ drop ] [ ] tri* update ]
[ drop define ] [ drop define ]
3bi ; [ 2drop make-inline ]
3tri ;
GENERIC# reader-quot 1 ( class slot-spec -- quot ) GENERIC# reader-quot 1 ( class slot-spec -- quot )
@ -41,11 +42,7 @@ M: object reader-quot
dup t "reader" set-word-prop ; dup t "reader" set-word-prop ;
: reader-props ( slot-spec -- assoc ) : reader-props ( slot-spec -- assoc )
[ "reading" associate ;
[ "reading" set ]
[ read-only>> [ t "foldable" set ] when ] bi
t "flushable" set
] H{ } make-assoc ;
: define-reader-generic ( name -- ) : define-reader-generic ( name -- )
reader-word (( object -- value )) define-simple-generic ; reader-word (( object -- value )) define-simple-generic ;

12
core/strings/strings.factor
View File

@ -37,24 +37,24 @@ M: string hashcode*
[ ] [ dup rehash-string string-hashcode ] ?if ; [ ] [ dup rehash-string string-hashcode ] ?if ;
M: string length M: string length
length>> ; length>> ; inline
M: string nth-unsafe M: string nth-unsafe
[ >fixnum ] dip string-nth ; [ >fixnum ] dip string-nth ; inline
M: string set-nth-unsafe M: string set-nth-unsafe
dup reset-string-hashcode dup reset-string-hashcode
[ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline
M: string clone 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> ; : 1string ( ch -- str ) 1 swap <string> ;
: >string ( seq -- str ) "" clone-like ; : >string ( seq -- str ) "" clone-like ;
M: string new-sequence drop 0 <string> ; M: string new-sequence drop 0 <string> ; inline
INSTANCE: string sequence INSTANCE: string sequence

8
core/vectors/vectors.factor
View File

@ -15,10 +15,10 @@ TUPLE: vector
M: vector like M: vector like
drop dup vector? [ drop dup vector? [
dup array? [ dup length vector boa ] [ >vector ] if dup array? [ dup length vector boa ] [ >vector ] if
] unless ; ] unless ; inline
M: vector new-sequence M: vector new-sequence
drop [ f <array> ] [ >fixnum ] bi vector boa ; drop [ f <array> ] [ >fixnum ] bi vector boa ; inline
M: vector equal? M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ; over vector? [ sequence= ] [ 2drop f ] if ;
@ -34,9 +34,9 @@ M: array like
2dup length eq? 2dup length eq?
[ nip ] [ resize-array ] if [ nip ] [ resize-array ] if
] [ >array ] if ] [ >array ] if
] unless ; ] unless ; inline
M: sequence new-resizable drop <vector> ; M: sequence new-resizable drop <vector> ; inline
INSTANCE: vector growable INSTANCE: vector growable

4
core/words/words.factor
View File

@ -12,7 +12,7 @@ IN: words
M: word execute (execute) ; M: word execute (execute) ;
M: word ?execute execute( -- value ) ; M: word ?execute execute( -- value ) ; inline
M: word <=> M: word <=>
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ; [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
@ -213,7 +213,7 @@ M: word forget*
] if ; ] if ;
M: word hashcode* M: word hashcode*
nip 1 slot { fixnum } declare ; foldable nip 1 slot { fixnum } declare ; inline foldable
M: word literalize <wrapper> ; M: word literalize <wrapper> ;