: <bit-array> ( n -- bit-array )
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
- [ >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 <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ; inline
M: bit-array equal?
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
resize-byte-array
] 2bi
bit-array boa
- dup clean-up ;
+ dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ;
} cond ;
: optimize? ( word -- ? )
- { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
+ single-generic? not ;
: contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ;
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?
GENERIC: xyz ( n -- n )
-M: integer xyz ;
+M: integer xyz ; inline
-M: object xyz ;
+M: object xyz ; inline
[ t ] [
[ { integer } declare xyz ] \ xyz inlined?
compiler.tree.cleanup
compiler.tree.propagation
compiler.tree.propagation.info
+compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing
compiler.tree.def-use
compiler.tree.builder
compiler.tree.optimizer
normalize
propagate
cleanup
+ escape-analysis
+ unbox-tuples
apply-identities
compute-def-use
remove-dead-code
ERROR: no-def-error value ;
: def-of ( value -- definition )
- dup def-use get at* [ nip ] [ no-def-error ] if ;
+ def-use get ?at [ no-def-error ] unless ;
ERROR: multiple-defs-error ;
USING: kernel tools.test compiler.tree compiler.tree.builder
-compiler.tree.def-use compiler.tree.def-use.simplified accessors
-sequences sorting classes ;
+compiler.tree.recursive compiler.tree.def-use
+compiler.tree.def-use.simplified accessors sequences sorting classes ;
IN: compiler.tree.def-use.simplified
[ { #call #return } ] [
first out-d>> first actually-used-by
[ node>> class ] map natural-sort
] unit-test
+
+: word-1 ( a -- b ) dup [ word-1 ] when ; inline recursive
+
+[ { #introduce } ] [
+ [ word-1 ] build-tree analyze-recursive compute-def-use
+ last in-d>> first actually-defined-by
+ [ node>> class ] map natural-sort
+] unit-test
+
+[ { #if #return } ] [
+ [ word-1 ] build-tree analyze-recursive compute-def-use
+ first out-d>> first actually-used-by
+ [ node>> class ] map natural-sort
+] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel fry vectors
-compiler.tree compiler.tree.def-use ;
+USING: sequences kernel fry vectors accessors namespaces assocs sets
+stack-checker.branches compiler.tree compiler.tree.def-use ;
IN: compiler.tree.def-use.simplified
! Simplified def-use follows chains of copies.
! A 'real' usage is a usage of a value that is not a #renaming.
TUPLE: real-usage value node ;
+<PRIVATE
+
+SYMBOLS: visited accum ;
+
+: if-not-visited ( value quot -- )
+ over visited get key?
+ [ 2drop ] [ over visited get conjoin call ] if ; inline
+
+: with-simplified-def-use ( quot -- real-usages )
+ [
+ H{ } clone visited set
+ H{ } clone accum set
+ call
+ accum get keys
+ ] with-scope ; inline
+
+PRIVATE>
+
! Def
-GENERIC: actually-defined-by* ( value node -- real-usage )
+GENERIC: actually-defined-by* ( value node -- )
-: actually-defined-by ( value -- real-usage )
- dup defined-by actually-defined-by* ;
+: (actually-defined-by) ( value -- )
+ [ dup defined-by actually-defined-by* ] if-not-visited ;
M: #renaming actually-defined-by*
- inputs/outputs swap [ index ] dip nth actually-defined-by ;
+ inputs/outputs swap [ index ] dip nth (actually-defined-by) ;
+
+M: #call-recursive actually-defined-by*
+ [ out-d>> index ] [ label>> return>> in-d>> nth ] bi
+ (actually-defined-by) ;
-M: #return-recursive actually-defined-by* real-usage boa ;
+M: #enter-recursive actually-defined-by*
+ [ out-d>> index ] keep
+ [ in-d>> nth (actually-defined-by) ]
+ [ label>> calls>> [ node>> in-d>> nth (actually-defined-by) ] with each ] 2bi ;
-M: node actually-defined-by* real-usage boa ;
+M: #phi actually-defined-by*
+ [ out-d>> index ] [ phi-in-d>> ] bi
+ [
+ nth dup +bottom+ eq?
+ [ drop ] [ (actually-defined-by) ] if
+ ] with each ;
+
+M: node actually-defined-by*
+ real-usage boa accum get conjoin ;
+
+: actually-defined-by ( value -- real-usages )
+ [ (actually-defined-by) ] with-simplified-def-use ;
! Use
-GENERIC# actually-used-by* 1 ( value node accum -- )
+GENERIC: actually-used-by* ( value node -- )
-: (actually-used-by) ( value accum -- )
- [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
+: (actually-used-by) ( value -- )
+ [ dup used-by [ actually-used-by* ] with each ] if-not-visited ;
M: #renaming actually-used-by*
- [ inputs/outputs [ indices ] dip nths ] dip
- '[ _ (actually-used-by) ] each ;
+ inputs/outputs [ indices ] dip nths
+ [ (actually-used-by) ] each ;
+
+M: #return-recursive actually-used-by*
+ [ in-d>> index ] keep
+ [ out-d>> nth (actually-used-by) ]
+ [ label>> calls>> [ node>> out-d>> nth (actually-used-by) ] with each ] 2bi ;
+
+M: #call-recursive actually-used-by*
+ [ in-d>> index ] [ label>> enter-out>> nth ] bi
+ (actually-used-by) ;
+
+M: #enter-recursive actually-used-by*
+ [ in-d>> index ] [ out-d>> nth ] bi (actually-used-by) ;
+
+M: #phi actually-used-by*
+ [ phi-in-d>> [ index ] with map-find drop ] [ out-d>> nth ] bi
+ (actually-used-by) ;
-M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
+M: #recursive actually-used-by* 2drop ;
-M: node actually-used-by* [ real-usage boa ] dip push ;
+M: node actually-used-by*
+ real-usage boa accum get conjoin ;
: actually-used-by ( value -- real-usages )
- 10 <vector> [ (actually-used-by) ] keep ;
+ [ (actually-used-by) ] with-simplified-def-use ;
! 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
"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 ;
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private tools.test math math.partial-dispatch
-math.private accessors slots.private sequences sequences.private strings sbufs
-compiler.tree.builder
-compiler.tree.normalization
-compiler.tree.debugger
-alien.accessors layouts combinators byte-arrays ;
+prettyprint math.private accessors slots.private sequences
+sequences.private strings sbufs compiler.tree.builder
+compiler.tree.normalization compiler.tree.debugger alien.accessors
+layouts combinators byte-arrays ;
IN: compiler.tree.modular-arithmetic.tests
: test-modular-arithmetic ( quot -- quot' )
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
] unit-test
-
-
[ t ] [
[
{ integer } declare [ 256 mod ] map
[ [ >fixnum 255 fixnum-bitand ] ]
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
+[ t ] [
+ [ { fixnum fixnum } declare + [ 1 + >fixnum ] [ 2 + >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
[ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
{ >fixnum } inlined?
] unit-test
+
+[ f ] [ [ + >fixnum ] { >fixnum } inlined? ] unit-test
+
+[ t ] [
+ [ >integer [ >fixnum ] [ >fixnum ] bi ]
+ { >integer } inlined?
+] unit-test
+
+[ f ] [
+ [ >integer [ >fixnum ] [ >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
+ { >integer } inlined?
+] unit-test
+
+[ f ] [
+ [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
+ { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+ [ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
+ { fixnum+ } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum boolean } declare [ 1 + ] [ "HI" throw ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum boolean } declare [ 1 + ] [ drop 5 ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum boolean } declare [ 1 + ] [ 2 + ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ [ [ 1 ] [ 4 ] if ] ] [
+ [ [ 1.5 ] [ 4 ] if >fixnum ] test-modular-arithmetic
+] unit-test
+
+[ [ [ 1 ] [ 2 ] if ] ] [
+ [ [ 1.5 ] [ 2.3 ] if >fixnum ] test-modular-arithmetic
+] unit-test
+
+[ f ] [
+ [ { fixnum fixnum boolean } declare [ [ 3 * ] [ 1 + ] dip ] [ [ 4 - ] [ 2 + ] dip ] if >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ 0 1000 [ 1 + dup >fixnum . ] times drop ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare 3 + [ 1000 ] dip [ >fixnum . ] curry times ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ 0 1000 [ 1 + ] times >fixnum ]
+ { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ f ] [
+ [ f >fixnum ]
+ { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+ [ [ >fixnum ] 2dip set-alien-unsigned-1 ]
+ { >fixnum } inlined?
+] unit-test
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.partial-dispatch namespaces sequences sets
-accessors assocs words kernel memoize fry combinators
+USING: math math.private math.partial-dispatch namespaces sequences
+sets accessors assocs words kernel memoize fry combinators
combinators.short-circuit layouts alien.accessors
compiler.tree
compiler.tree.combinators
+compiler.tree.propagation.info
compiler.tree.def-use
compiler.tree.def-use.simplified
compiler.tree.late-optimizations ;
! ==>
! [ >fixnum ] bi@ fixnum+fast
+! Words where the low-order bits of the output only depends on the
+! low-order bits of the input. If the output is only used for its
+! low-order bits, then the word can be converted into a form that is
+! cheaper to compute.
{ + - * bitand bitor bitxor } [
[
t "modular-arithmetic" set-word-prop
] each-integer-derived-op
] each
-{ bitand bitor bitxor bitnot }
+{ bitand bitor bitxor bitnot >integer }
[ t "modular-arithmetic" set-word-prop ] each
+! Words that only use the low-order bits of their input. If the input
+! is a modular arithmetic word, then the input can be converted into
+! a form that is cheaper to compute.
{
- >fixnum
+ >fixnum bignum>fixnum float>fixnum
set-alien-unsigned-1 set-alien-signed-1
set-alien-unsigned-2 set-alien-signed-2
}
] when
[ t "low-order" set-word-prop ] each
-SYMBOL: modularize-values
+! Values which only have their low-order bits used. This set starts out
+! big and is gradually refined.
+SYMBOL: modular-values
: modular-value? ( value -- ? )
- modularize-values get key? ;
+ modular-values get key? ;
-: modularize-value ( value -- ) modularize-values get conjoin ;
+: modular-value ( value -- )
+ modular-values get conjoin ;
-GENERIC: maybe-modularize* ( value node -- )
+! Values which are known to be fixnums.
+SYMBOL: fixnum-values
-: maybe-modularize ( value -- )
- actually-defined-by [ value>> ] [ node>> ] bi
- over actually-used-by length 1 = [
- maybe-modularize*
- ] [ 2drop ] if ;
+: fixnum-value? ( value -- ? )
+ fixnum-values get key? ;
-M: #call maybe-modularize*
- dup word>> "modular-arithmetic" word-prop [
- [ modularize-value ]
- [ in-d>> [ maybe-modularize ] each ] bi*
- ] [ 2drop ] if ;
+: fixnum-value ( value -- )
+ fixnum-values get conjoin ;
-M: node maybe-modularize* 2drop ;
+GENERIC: compute-modular-candidates* ( node -- )
-GENERIC: compute-modularized-values* ( node -- )
+M: #push compute-modular-candidates*
+ [ out-d>> first ] [ literal>> ] bi
+ real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
-M: #call compute-modularized-values*
- dup word>> "low-order" word-prop
- [ in-d>> first maybe-modularize ] [ drop ] if ;
+M: #call compute-modular-candidates*
+ {
+ {
+ [ dup word>> "modular-arithmetic" word-prop ]
+ [ out-d>> first [ modular-value ] [ fixnum-value ] bi ]
+ }
+ {
+ [ dup word>> "low-order" word-prop ]
+ [ in-d>> first modular-value ]
+ }
+ [ drop ]
+ } cond ;
+
+M: node compute-modular-candidates*
+ drop ;
+
+: compute-modular-candidates ( nodes -- )
+ H{ } clone modular-values set
+ H{ } clone fixnum-values set
+ [ compute-modular-candidates* ] each-node ;
+
+GENERIC: only-reads-low-order? ( node -- ? )
+
+M: #call only-reads-low-order?
+ {
+ [ word>> "low-order" word-prop ]
+ [
+ {
+ [ word>> "modular-arithmetic" word-prop ]
+ [ out-d>> first modular-values get key? ]
+ } 1&&
+ ]
+ } 1|| ;
+
+M: node only-reads-low-order? drop f ;
-M: node compute-modularized-values* drop ;
+SYMBOL: changed?
-: compute-modularized-values ( nodes -- )
- [ compute-modularized-values* ] each-node ;
+: only-used-as-low-order? ( value -- ? )
+ actually-used-by [ node>> only-reads-low-order? ] all? ;
+
+: (compute-modular-values) ( -- )
+ modular-values get keys [
+ dup only-used-as-low-order?
+ [ drop ] [ modular-values get delete-at changed? on ] if
+ ] each ;
+
+: compute-modular-values ( -- )
+ [ changed? off (compute-modular-values) changed? get ] loop ;
GENERIC: optimize-modular-arithmetic* ( node -- nodes )
+M: #push optimize-modular-arithmetic*
+ dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and
+ [ [ >fixnum ] change-literal ] when ;
+
: redundant->fixnum? ( #call -- ? )
- in-d>> first actually-defined-by value>> modular-value? ;
+ in-d>> first actually-defined-by
+ [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ;
: optimize->fixnum ( #call -- nodes )
dup redundant->fixnum? [ drop f ] when ;
+: should-be->fixnum? ( #call -- ? )
+ out-d>> first modular-value? ;
+
: optimize->integer ( #call -- nodes )
- dup out-d>> first actually-used-by dup length 1 = [
- first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
- [ drop { } ] when
- ] [ drop ] if ;
+ dup should-be->fixnum? [ \ >fixnum >>word ] when ;
MEMO: fixnum-coercion ( flags -- nodes )
+ ! flags indicate which input parameters are already known to be fixnums,
+ ! and don't need a coercion as a result.
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
+: modular-value-info ( #call -- alist )
+ [ in-d>> ] [ out-d>> ] bi append
+ fixnum <class-info> '[ _ ] { } map>assoc ;
+
: optimize-modular-op ( #call -- nodes )
dup out-d>> first modular-value? [
[ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
[
[
- [ actually-defined-by value>> modular-value? ]
+ [ actually-defined-by [ value>> modular-value? ] all? ]
[ fixnum eq? ]
bi* or
] 2map fixnum-coercion
] [ [ modular-variant ] change-word ] bi* suffix
] when ;
+: optimize-low-order-op ( #call -- nodes )
+ dup in-d>> first fixnum-value? [
+ [ ] [ in-d>> first ] [ info>> ] tri
+ [ drop fixnum <class-info> ] change-at
+ ] when ;
+
M: #call optimize-modular-arithmetic*
dup word>> {
- { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+ { [ dup { >fixnum bignum>fixnum float>fixnum } memq? ] [ drop optimize->fixnum ] }
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
+ { [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] }
[ drop ]
} cond ;
M: node optimize-modular-arithmetic* ;
: optimize-modular-arithmetic ( nodes -- nodes' )
- H{ } clone modularize-values set
- dup compute-modularized-values
+ dup compute-modular-candidates compute-modular-values
[ optimize-modular-arithmetic* ] map-nodes ;
: (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 ]
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
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 ;
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 ;
{ [ 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 ;
[ 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
] 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
] 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
] 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
[ 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
[ 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
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) ;
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
MIXIN: subseq-chunking
-M: subseq-chunking nth group@ subseq ;
+M: subseq-chunking nth group@ subseq ; inline
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 ;
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>
SINGLETON: ascii
M: ascii encode-char
- 128 encode-if< ;
+ 128 encode-if< ; inline
M: ascii decode-char
- 128 decode-if< ;
+ 128 decode-if< ; inline
: make-bits ( number -- bits )
[ 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
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
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
GENERIC: absq ( x -- y ) foldable
-M: real absq sq ;
+M: real absq sq ; inline
: ~abs ( x y epsilon -- ? )
[ - abs ] dip < ;
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> ;
[ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real cos fcos ;
+M: real cos fcos ; inline
: sec ( x -- y ) cos recip ; inline
[ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real cosh fcosh ;
+M: real cosh fcosh ; inline
: sech ( x -- y ) cosh recip ; inline
[ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real sin fsin ;
+M: real sin fsin ; inline
: cosec ( x -- y ) sin recip ; inline
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real sinh fsinh ;
+M: real sinh fsinh ; inline
: cosech ( x -- y ) sinh recip ; inline
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
M: complex atan i* atanh i* ;
-M: real atan fatan ;
+M: real atan fatan ; inline
: asec ( x -- y ) recip acos ; inline
: <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)
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 <= ;
""
} ;
+HELP: HEREDOC:
+{ $syntax "HEREDOC: marker\n...text...marker" }
+{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "" "a string" } }
+{ $description "A multiline string syntax with a user-specified terminating delimiter. HEREDOC: reads the next word, and uses it as the 'close quote'. All input from the beginning of the HEREDOC:'s next line, until the first appearance of the word's name, becomes a string. The terminating word does not need to be at the beginning of a line.\n\nThe HEREDOC: line should not have anything after the delimiting word. The delimiting word should be an alphanumeric token. It should not be, as in some other languages, a \"quoted string\"." }
+{ $examples
+ { $example "USING: multiline prettyprint ;"
+ "HEREDOC: END\nx\nEND ."
+ "\"x\\n\""
+ }
+ { $example "USING: multiline prettyprint ;"
+ "HEREDOC: END\nxEND ."
+ "\"x\""
+ }
+ { $example "USING: multiline prettyprint sequences ;"
+ "2 5 HEREDOC: zap\nfoo\nbarzap subseq ."
+ "\"o\\nb\""
+ }
+} ;
+
{ POSTPONE: <" POSTPONE: STRING: } related-words
HELP: parse-multiline-string
"Multiline strings:"
{ $subsection POSTPONE: STRING: }
{ $subsection POSTPONE: <" }
+{ $subsection POSTPONE: HEREDOC: }
"Multiline comments:"
{ $subsection POSTPONE: /* }
"Writing new multiline parsing words:"
[ "\nhi" ] [ <"
hi"> ] unit-test
+
+
+! HEREDOC:
+
+[ "foo\nbar\n" ] [ HEREDOC: END
+foo
+bar
+END ] unit-test
+
+[ "foo\nbar" ] [ HEREDOC: END
+foo
+barEND ] unit-test
+
+[ "" ] [ HEREDOC: END
+END ] unit-test
+
+[ " " ] [ HEREDOC: END
+ END ] unit-test
+
+[ "\n" ] [ HEREDOC: END
+
+END ] unit-test
+
+[ "x" ] [ HEREDOC: END
+xEND ] unit-test
+
+[ "xyz " ] [ HEREDOC: END
+xyz END ] unit-test
+
+[ "} ! * # \" «\n" ] [ HEREDOC: END
+} ! * # " «
+END ] unit-test
+
+[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
+foo
+barX HEREDOC: END ! mumble
+ HEREDOC: FOO
+ FOO
+END 22 ] unit-test
+
<PRIVATE
-:: (parse-multiline-string) ( i end -- j )
+:: (scan-multiline-string) ( i end -- j )
lexer get line-text>> :> text
text [
end text i start* [| j |
] [
text i short tail % CHAR: \n ,
lexer get next-line
- 0 end (parse-multiline-string)
+ 0 end (scan-multiline-string)
] if*
] [ end unexpected-eof ] if ;
-PRIVATE>
-
-: parse-multiline-string ( end-text -- str )
+:: (parse-multiline-string) ( end-text skip-n-chars -- str )
[
lexer get
- [ 1 + swap (parse-multiline-string) ]
+ [ skip-n-chars + end-text (scan-multiline-string) ]
change-column drop
] "" make ;
+PRIVATE>
+
+: parse-multiline-string ( end-text -- str )
+ 1 (parse-multiline-string) ;
+
SYNTAX: <"
"\">" parse-multiline-string parsed ;
"\"}" parse-multiline-string parsed ;
SYNTAX: /* "*/" parse-multiline-string drop ;
+
+SYNTAX: HEREDOC:
+ scan
+ lexer get next-line
+ 0 (parse-multiline-string)
+ parsed ;
WHERE
-: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
;FUNCTOR
dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
swap A boa ; inline
-M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
+M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
-M: A length length>> ;
+M: A length length>> ; inline
-M: A nth-unsafe underlying>> NTH call ;
+M: A nth-unsafe underlying>> NTH call ; inline
-M: A set-nth-unsafe underlying>> SET-NTH call ;
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
-: >A ( seq -- specialized-array ) A new clone-like ; inline
+: >A ( seq -- specialized-array ) A new clone-like ;
-M: A like drop dup A instance? [ >A ] unless ;
+M: A like drop dup A instance? [ >A ] unless ; inline
-M: A new-sequence drop (A) ;
+M: A new-sequence drop (A) ; inline
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
[ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
] 2bi
- A boa ;
+ A boa ; inline
-M: A byte-length underlying>> length ;
+M: A byte-length underlying>> length ; inline
M: A pprint-delims drop \ A{ \ } ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
+\ <tuple-boa> t "flushable" set-word-prop
+
: infer-effect-unsafe ( word -- )
pop-literal nip
add-effect-input
[ \ CLASS [ tuple-prototype <repetition> 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 <CLASS-array> ;
+M: CLASS-array new-sequence drop <CLASS-array> ; inline
: >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
M: V like
drop dup V instance? [
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 ;
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
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
-TUPLE: ole32-error error-code ;
-C: <ole32-error> ole32-error
+TUPLE: ole32-error code message ;
-M: ole32-error error.
- "COM method failed: " print error-code>> n>win32-error-string print ;
+: <ole32-error> ( code -- error )
+ dup n>win32-error-string \ ole32-error boa ;
: ole32-error ( hresult -- )
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
}
refresh_image() {
- ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit"
+ ./$FACTOR_BINARY -script -e="USING: vocabs.loader system memory ; refresh-all USE: memory save 0 exit"
check_ret factor
}
make_boot_image() {
- ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit"
+ ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USING: system bootstrap.image memory ; make-image save 0 exit"
check_ret factor
}
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
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 <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?
over array? [ sequence= ] [ 2drop f ] if ;
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
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 ;
[ 2nip set-second ]
[ 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
[ 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> 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
-USING: tools.test byte-arrays sequences kernel ;\r
+USING: tools.test byte-arrays sequences kernel math ;\r
IN: byte-arrays.tests\r
\r
[ 6 B{ 1 2 3 } ] [\r
[ -10 B{ } resize-byte-array ] must-fail\r
\r
[ B{ 123 } ] [ 123 1byte-array ] unit-test\r
+\r
+[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test\r
+\r
+[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test
\ No newline at end of file
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
drop dup byte-vector? [\r
dup byte-array?\r
[ dup length byte-vector boa ] [ >byte-vector ] if\r
- ] unless ;\r
+ ] unless ; inline\r
\r
M: byte-vector new-sequence\r
- drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
+ drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline\r
\r
M: byte-vector equal?\r
over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
\r
-M: byte-vector contract 2drop ;\r
+M: byte-vector contract 2drop ; inline\r
\r
M: byte-array like\r
#! If we have an byte-array, we're done.\r
2dup length eq?\r
[ nip ] [ resize-byte-array ] if\r
] [ >byte-array ] if\r
- ] unless ;\r
+ ] unless ; inline\r
\r
-M: byte-array new-resizable drop <byte-vector> ;\r
+M: byte-array new-resizable drop <byte-vector> ; inline\r
\r
INSTANCE: byte-vector growable\r
: 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 ;
: 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
[ swap classes-intersect? ]
} cond ;
-M: tuple clone (clone) ;
+M: tuple clone (clone) ; inline
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
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
[ >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
] if ;
M: hashtable assoc-size ( hash -- n )
- [ count>> ] [ deleted>> ] bi - ;
+ [ count>> ] [ deleted>> ] bi - ; inline
: rehash ( hash -- )
dup >alist [
] keep { } like ;
M: hashtable clone
- (clone) [ clone ] change-array ;
+ (clone) [ clone ] change-array ; inline
M: hashtable equal?
over hashtable? [
] [ 2drop f ] if ;
! 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 )
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* ;
dup stream-read1 dup [ begin-utf8 ] when nip ; inline
M: utf8 decode-char
- drop decode-utf8 ;
+ drop decode-utf8 ; inline
! Encoding UTF-8
USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings namespaces ;
+io.encodings.utf8 io kernel arrays strings namespaces math ;
[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
read1
] with-byte-reader
] unit-test
+
+! Overly aggressive compiler optimizations
+[ B{ 123 } ] [
+ binary [ 123 >bignum write1 ] with-byte-writer
+] unit-test
\ No newline at end of file
! 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 ] [
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 )
M: real >integer
dup most-negative-fixnum most-positive-fixnum between?
- [ >fixnum ] [ >bignum ] if ;
+ [ >fixnum ] [ >bignum ] if ; inline
UNION: immediate fixnum POSTPONE: f ;
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
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:
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
: <fp-nan> ( payload -- nan )
- HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+ HEX: 7ff0000000000000 bitor bits>double ; inline
: next-float ( m -- n )
double>bits
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
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
: >=< ( 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
: <sbuf> ( n -- sbuf ) 0 <string> 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 <string> ] [ >fixnum ] bi sbuf boa ;
+ drop [ 0 <string> ] [ >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 <sbuf> ;
+M: sbuf new-resizable drop <sbuf> ; inline
M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ;
-M: string new-resizable drop <sbuf> ;
+M: string new-resizable drop <sbuf> ; inline
M: string like
#! If we have a string, we're done.
2dup length eq?
[ nip dup reset-string-hashcode ] [ resize-string ] if
] [ >string ] if
- ] unless ;
+ ] unless ; inline
INSTANCE: sbuf growable
"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
ARTICLE: "sequences-if" "Control flow with sequences"
-"To reduce the boilerplate of checking if a sequence is empty or a number is zero, several combinators are provided."
+"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided."
$nl
"Checking if a sequence is empty:"
{ $subsection if-empty }
: 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
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
<PRIVATE
-M: iota length n>> ;
-M: iota nth-unsafe drop ;
+M: iota length n>> ; inline
+M: iota nth-unsafe drop ; inline
INSTANCE: iota immutable-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
C: <reversed> 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
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
C: <repetition> 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
(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 ;
[ create-method ] 2dip
[ [ props>> ] [ drop ] [ ] tri* update ]
[ drop define ]
- 3bi ;
+ [ 2drop make-inline ]
+ 3tri ;
GENERIC# reader-quot 1 ( class slot-spec -- 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 ;
[ ] [ 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> ;
: >string ( seq -- str ) "" clone-like ;
-M: string new-sequence drop 0 <string> ;
+M: string new-sequence drop 0 <string> ; inline
INSTANCE: string sequence
M: vector like
drop dup vector? [
dup array? [ dup length vector boa ] [ >vector ] if
- ] unless ;
+ ] unless ; inline
M: vector new-sequence
- drop [ f <array> ] [ >fixnum ] bi vector boa ;
+ drop [ f <array> ] [ >fixnum ] bi vector boa ; inline
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
2dup length eq?
[ nip ] [ resize-array ] if
] [ >array ] if
- ] unless ;
+ ] unless ; inline
-M: sequence new-resizable drop <vector> ;
+M: sequence new-resizable drop <vector> ; inline
INSTANCE: vector growable
M: word execute (execute) ;
-M: word ?execute execute( -- value ) ;
+M: word ?execute execute( -- value ) ; inline
M: word <=>
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
] if ;
M: word hashcode*
- nip 1 slot { fixnum } declare ; foldable
+ nip 1 slot { fixnum } declare ; inline foldable
M: word literalize <wrapper> ;
255 min 0 max ; inline
: stride ( line yuv -- uvy yy )
- [ yuv_buffer-uv_stride swap 2/ * >fixnum ]
- [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline
+ [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline
: compute-y ( yuv uvy yy x -- y )
+ >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
drop ; inline
: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
- compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+ compute-yuv compute-rgb store-rgb 3 + ; inline
: yuv>rgb-row ( index rgb yuv y -- index )
over stride
- pick yuv_buffer-y_width >fixnum
+ pick yuv_buffer-y_width
[ yuv>rgb-pixel ] with with with with each ; inline
: yuv>rgb ( rgb yuv -- )
[ 0 ] 2dip
- dup yuv_buffer-y_height >fixnum
+ dup yuv_buffer-y_height
[ yuv>rgb-row ] with with each
drop ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations debugger io compiler.units
+kernel.private effects accessors hashtables sorting shuffle
+math.order sets see effects.parser ;
+IN: multi-methods
+
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
+
+SYMBOL: args
+
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] filter
+ [ length <reversed> [ 1 + neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] filter
+ [ keys [ hooks get adjoin ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ [ total get object <array> dup <enum> ] dip update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
+
+ args get hooks get length + total set
+
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
+: maximal-element ( seq quot -- n elt )
+ dupd [
+ swapd [ call +lt+ = ] 2curry filter empty?
+ ] 2curry find [ "Topological sort failed" throw ] unless* ;
+ inline
+
+: topological-sort ( seq quot -- newseq )
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over delete-nth ] dip ] curry
+ produce nip ; inline
+
+: classes< ( seq1 seq2 -- lt/eq/gt )
+ [
+ {
+ { [ 2dup eq? ] [ +eq+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
+ [ +eq+ ]
+ } cond 2nip
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
+
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1 - picker [ dip swap ] curry ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap "predicate" word-prop append ;
+
+: multi-predicate ( classes -- quot )
+ dup length <reversed>
+ [ picker 2array ] 2map
+ [ drop object eq? not ] assoc-filter
+ [ [ t ] ] [
+ [ (multi-predicate) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if-empty ;
+
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
+: methods ( word -- alist )
+ "multi-methods" word-prop >alist ;
+
+: make-generic ( generic -- quot )
+ [
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
+ ] [ ] make ;
+
+: update-generic ( word -- )
+ dup make-generic define ;
+
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
+
+M: method-body stack-effect
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ "forgotten" word-prop not ;
+
+: method-word-name ( specializer generic -- string )
+ [ name>> % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
+ [
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ swap >>props ;
+
+: with-methods ( word quot -- )
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
+
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
+
+M: no-method error.
+ "Type check error" print
+ nl
+ "Generic word " write dup generic>> pprint
+ " does not have a method applicable to inputs:" print
+ dup arguments>> short.
+ nl
+ "Inputs have signature:" print
+ dup arguments>> [ class ] map niceify-method .
+ nl
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
+
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
+
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word effect -- )
+ over set-stack-effect
+ dup "multi-methods" word-prop [ drop ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
+ ] if ;
+
+! Syntax
+SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
+
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
+
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+SYNTAX: METHOD: (METHOD:) define ;
+
+! For compatibility
+SYNTAX: M:
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ;
+
+! Definition protocol. We qualify core generics here
+QUALIFIED: syntax
+
+syntax:M: generic definer drop \ GENERIC: f ;
+
+syntax:M: generic definition drop f ;
+
+PREDICATE: method-spec < array
+ unclip generic? [ [ class? ] all? ] dip and ;
+
+syntax:M: method-spec where
+ dup unclip method [ ] [ first ] ?if where ;
+
+syntax:M: method-spec set-where
+ unclip method set-where ;
+
+syntax:M: method-spec definer
+ unclip method definer ;
+
+syntax:M: method-spec definition
+ unclip method definition ;
+
+syntax:M: method-spec synopsis*
+ unclip method synopsis* ;
+
+syntax:M: method-spec forget*
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+extensions
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+IN: multi-methods.tests
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test ( -- )
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1 ( -- seq )
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+CONSTANT: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ }
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ { cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+IN: multi-methods.tests
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+<< (( -- )) \ fake set-stack-effect >>
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing (( -- )) define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+USING: math strings sequences tools.test ;
+IN: multi-methods.tests
+
+GENERIC: legacy-test ( a -- b )
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors see ;
+RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
+IN: multi-methods.tests
+
+multi-methods:GENERIC: first-test ( -- )
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
+
+METHOD: beats? { paper scissors } 2drop t ;
+METHOD: beats? { scissors rock } 2drop t ;
+METHOD: beats? { rock paper } 2drop t ;
+METHOD: beats? { thing thing } 2drop f ;
+
+: play ( obj1 obj2 -- ? ) beats? ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+multi-methods:GENERIC: hook-test ( obj -- obj )
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+USING: kernel multi-methods tools.test math arrays sequences
+math.order ;
+IN: multi-methods.tests
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ +lt+ ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ +eq+ ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ +gt+ ] [
+ { object object } { number sequence } classes<
+] unit-test
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io kernel lists math math.parser
+sequences splitting ;
+IN: rpn
+
+SINGLETONS: add-insn sub-insn mul-insn div-insn ;
+TUPLE: push-insn value ;
+
+GENERIC: eval-insn ( stack insn -- stack )
+
+: binary-op ( stack quot: ( x y -- z ) -- stack )
+ [ uncons uncons ] dip dip cons ; inline
+
+M: add-insn eval-insn drop [ + ] binary-op ;
+M: sub-insn eval-insn drop [ - ] binary-op ;
+M: mul-insn eval-insn drop [ * ] binary-op ;
+M: div-insn eval-insn drop [ / ] binary-op ;
+M: push-insn eval-insn value>> swons ;
+
+: rpn-tokenize ( string -- string' )
+ " " split harvest sequence>list ;
+
+: rpn-parse ( string -- tokens )
+ rpn-tokenize [
+ {
+ { "+" [ add-insn ] }
+ { "-" [ sub-insn ] }
+ { "*" [ mul-insn ] }
+ { "/" [ div-insn ] }
+ [ string>number push-insn boa ]
+ } case
+ ] lmap ;
+
+: print-stack ( list -- )
+ [ number>string print ] leach ;
+
+: rpn-eval ( tokens -- )
+ nil [ eval-insn ] foldl print-stack ;
+
+: rpn ( -- )
+ "RPN> " write flush
+ readln [ rpn-parse rpn-eval rpn ] when* ;
+
+MAIN: rpn
--- /dev/null
+Simple RPN calculator
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations debugger io compiler.units
-kernel.private effects accessors hashtables sorting shuffle
-math.order sets see effects.parser ;
-IN: multi-methods
-
-! PART I: Converting hook specializers
-: canonicalize-specializer-0 ( specializer -- specializer' )
- [ \ f or ] map ;
-
-SYMBOL: args
-
-SYMBOL: hooks
-
-SYMBOL: total
-
-: canonicalize-specializer-1 ( specializer -- specializer' )
- [
- [ class? ] filter
- [ length <reversed> [ 1+ neg ] map ] keep zip
- [ length args [ max ] change ] keep
- ]
- [
- [ pair? ] filter
- [ keys [ hooks get adjoin ] each ] keep
- ] bi append ;
-
-: canonicalize-specializer-2 ( specializer -- specializer' )
- [
- [
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get +
- ] dip
- ] assoc-map ;
-
-: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> dup <enum> ] dip update ;
-
-: canonicalize-specializers ( methods -- methods' hooks )
- [
- [ [ canonicalize-specializer-0 ] dip ] assoc-map
-
- 0 args set
- V{ } clone hooks set
-
- [ [ canonicalize-specializer-1 ] dip ] assoc-map
-
- hooks [ natural-sort ] change
-
- [ [ canonicalize-specializer-2 ] dip ] assoc-map
-
- args get hooks get length + total set
-
- [ [ canonicalize-specializer-3 ] dip ] assoc-map
-
- hooks get
- ] with-scope ;
-
-: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
-
-: prepare-method ( method n -- quot )
- [ 1quotation ] [ drop-n-quot ] bi* prepend ;
-
-: prepare-methods ( methods -- methods' prologue )
- canonicalize-specializers
- [ length [ prepare-method ] curry assoc-map ] keep
- [ [ get ] curry ] map concat [ ] like ;
-
-! Part II: Topologically sorting specializers
-: maximal-element ( seq quot -- n elt )
- dupd [
- swapd [ call +lt+ = ] 2curry filter empty?
- ] 2curry find [ "Topological sort failed" throw ] unless* ;
- inline
-
-: topological-sort ( seq quot -- newseq )
- [ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over delete-nth ] dip ] curry
- produce nip ; inline
-
-: classes< ( seq1 seq2 -- lt/eq/gt )
- [
- {
- { [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
- { [ 2dup class<= ] [ +lt+ ] }
- { [ 2dup swap class<= ] [ +gt+ ] }
- [ +eq+ ]
- } cond 2nip
- ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
-
-: sort-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
-! PART III: Creating dispatch quotation
-: picker ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- picker [ dip swap ] curry ]
- } case ;
-
-: (multi-predicate) ( class picker -- quot )
- swap "predicate" word-prop append ;
-
-: multi-predicate ( classes -- quot )
- dup length <reversed>
- [ picker 2array ] 2map
- [ drop object eq? not ] assoc-filter
- [ [ t ] ] [
- [ (multi-predicate) ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if-empty ;
-
-: argument-count ( methods -- n )
- keys 0 [ length max ] reduce ;
-
-ERROR: no-method arguments generic ;
-
-: make-default-method ( methods generic -- quot )
- [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- [ make-default-method ]
- [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
- 2bi alist>quot ;
-
-! Generic words
-PREDICATE: generic < word
- "multi-methods" word-prop >boolean ;
-
-: methods ( word -- alist )
- "multi-methods" word-prop >alist ;
-
-: make-generic ( generic -- quot )
- [
- [ methods prepare-methods % sort-methods ] keep
- multi-dispatch-quot %
- ] [ ] make ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-! Methods
-PREDICATE: method-body < word
- "multi-method-generic" word-prop >boolean ;
-
-M: method-body stack-effect
- "multi-method-generic" word-prop stack-effect ;
-
-M: method-body crossref?
- "forgotten" word-prop not ;
-
-: method-word-name ( specializer generic -- string )
- [ name>> % "-" % unparse % ] "" make ;
-
-: method-word-props ( specializer generic -- assoc )
- [
- "multi-method-generic" set
- "multi-method-specializer" set
- ] H{ } make-assoc ;
-
-: <method> ( specializer generic -- word )
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
-
-: with-methods ( word quot -- )
- over [
- [ "multi-methods" word-prop ] dip call
- ] dip update-generic ; inline
-
-: reveal-method ( method classes generic -- )
- [ set-at ] with-methods ;
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: create-method ( classes generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
- ] if ;
-
-: niceify-method ( seq -- seq )
- [ dup \ f eq? [ drop f ] when ] map ;
-
-M: no-method error.
- "Type check error" print
- nl
- "Generic word " write dup generic>> pprint
- " does not have a method applicable to inputs:" print
- dup arguments>> short.
- nl
- "Inputs have signature:" print
- dup arguments>> [ class ] map niceify-method .
- nl
- "Available methods: " print
- generic>> methods canonicalize-specializers drop sort-methods
- keys [ niceify-method ] map stack. ;
-
-: forget-method ( specializer generic -- )
- [ delete-at ] with-methods ;
-
-: method>spec ( method -- spec )
- [ "multi-method-specializer" word-prop ]
- [ "multi-method-generic" word-prop ] bi prefix ;
-
-: define-generic ( word effect -- )
- over set-stack-effect
- dup "multi-methods" word-prop [ drop ] [
- [ H{ } clone "multi-methods" set-word-prop ]
- [ update-generic ]
- bi
- ] if ;
-
-! Syntax
-SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
-
-: parse-method ( -- quot classes generic )
- parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-
-: create-method-in ( specializer generic -- method )
- create-method dup save-location f set-word ;
-
-: CREATE-METHOD ( -- method )
- scan-word scan-object swap create-method-in ;
-
-: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
-
-SYNTAX: METHOD: (METHOD:) define ;
-
-! For compatibility
-SYNTAX: M:
- scan-word 1array scan-word create-method-in
- parse-definition
- define ;
-
-! Definition protocol. We qualify core generics here
-QUALIFIED: syntax
-
-syntax:M: generic definer drop \ GENERIC: f ;
-
-syntax:M: generic definition drop f ;
-
-PREDICATE: method-spec < array
- unclip generic? [ [ class? ] all? ] dip and ;
-
-syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
-
-syntax:M: method-spec set-where
- unclip method set-where ;
-
-syntax:M: method-spec definer
- unclip method definer ;
-
-syntax:M: method-spec definition
- unclip method definition ;
-
-syntax:M: method-spec synopsis*
- unclip method synopsis* ;
-
-syntax:M: method-spec forget*
- unclip method forget* ;
-
-syntax:M: method-body definer
- drop \ METHOD: \ ; ;
-
-syntax:M: method-body synopsis*
- dup definer.
- [ "multi-method-generic" word-prop pprint-word ]
- [ "multi-method-specializer" word-prop pprint* ] bi ;
+++ /dev/null
-Experimental multiple dispatch implementation
+++ /dev/null
-extensions
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings ;
-
-[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
-
-: setup-canon-test ( -- )
- 0 args set
- V{ } clone hooks set ;
-
-: canon-test-1 ( -- seq )
- { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
-
-[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- ] with-scope
-] unit-test
-
-[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- ] with-scope
-] unit-test
-
-[ { integer sequence x86 } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- args get hooks get length + total set
- canonicalize-specializer-3
- ] with-scope
-] unit-test
-
-CONSTANT: example-1
- {
- { { { cpu x86 } { os linux } } "a" }
- { { { cpu ppc } } "b" }
- { { string { os windows } } "c" }
- }
-
-[
- {
- { { object x86 linux } "a" }
- { { object ppc object } "b" }
- { { string object windows } "c" }
- }
- { cpu os }
-] [
- example-1 canonicalize-specializers
-] unit-test
-
-[
- {
- { { object x86 linux } [ drop drop "a" ] }
- { { object ppc object } [ drop drop "b" ] }
- { { string object windows } [ drop drop "c" ] }
- }
- [ \ cpu get \ os get ]
-] [
- example-1 prepare-methods
-] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings words compiler.units quotations ;
-
-DEFER: fake
-\ fake H{ } clone "multi-methods" set-word-prop
-
-[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-
-[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
-[ { } \ fake method-word-props ] unit-test
-
-[ t ] [ { } \ fake <method> method-body? ] unit-test
-
-[
- [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
-
- [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
-
- [ t ] [ \ fake make-generic quotation? ] unit-test
-
- [ ] [ \ fake update-generic ] unit-test
-
- DEFER: testing
-
- [ ] [ \ testing (( -- )) define-generic ] unit-test
-
- [ t ] [ \ testing generic? ] unit-test
-] with-compilation-unit
+++ /dev/null
-IN: multi-methods.tests
-USING: math strings sequences tools.test ;
-
-GENERIC: legacy-test ( a -- b )
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors see ;
-
-GENERIC: first-test ( -- )
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-SINGLETON: paper INSTANCE: paper thing
-SINGLETON: scissors INSTANCE: scissors thing
-SINGLETON: rock INSTANCE: rock thing
-
-GENERIC: beats? ( obj1 obj2 -- ? )
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ { { } 3 } ] [ error get arguments>> ] unit-test
-[ t ] [ paper scissors play ] unit-test
-[ f ] [ scissors paper play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-SYMBOL: some-var
-
-GENERIC: hook-test ( -- obj )
-
-METHOD: hook-test { array { some-var array } } reverse ;
-METHOD: hook-test { { some-var array } } class ;
-METHOD: hook-test { hashtable { some-var number } } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-"error" some-var set
-[ H{ } hook-test ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ { H{ } "error" } ] [ error get arguments>> ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
+++ /dev/null
-USING: kernel multi-methods tools.test math arrays sequences
-math.order ;
-IN: multi-methods.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ +lt+ ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ +eq+ ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ +gt+ ] [
- { object object } { number sequence } classes<
-] unit-test
projects / factor.git / commitdiff