Merge branch 'master' into new_optimizer
commit
60dd301497
|
@ -104,8 +104,7 @@ ERROR: bad-superclass class ;
|
|||
[ tuple-instance? ] 2curry define-predicate ;
|
||||
|
||||
: superclass-size ( class -- n )
|
||||
superclasses but-last-slice
|
||||
[ "slots" word-prop length ] sigma ;
|
||||
superclasses but-last [ "slots" word-prop length ] sigma ;
|
||||
|
||||
: (instance-check-quot) ( class -- quot )
|
||||
[
|
||||
|
@ -203,11 +202,11 @@ ERROR: bad-superclass class ;
|
|||
|
||||
M: tuple-class update-class
|
||||
{
|
||||
[ define-boa-check ]
|
||||
[ define-tuple-layout ]
|
||||
[ define-tuple-slots ]
|
||||
[ define-tuple-predicate ]
|
||||
[ define-tuple-prototype ]
|
||||
[ define-boa-check ]
|
||||
} cleave ;
|
||||
|
||||
: define-new-tuple-class ( class superclass slots -- )
|
||||
|
@ -280,11 +279,8 @@ M: tuple-class reset-class
|
|||
] with each
|
||||
] [
|
||||
[ call-next-method ]
|
||||
[
|
||||
{
|
||||
"layout" "slots" "boa-check" "prototype"
|
||||
} reset-props
|
||||
] bi
|
||||
[ { "layout" "slots" "boa-check" "prototype" } reset-props ]
|
||||
bi
|
||||
] bi ;
|
||||
|
||||
M: tuple-class rank-class drop 0 ;
|
||||
|
|
|
@ -117,10 +117,10 @@ ERROR: no-case ;
|
|||
] [ drop f ] if ;
|
||||
|
||||
: dispatch-case ( value from to default array -- )
|
||||
>r >r 3dup between? [
|
||||
drop - >fixnum r> drop r> dispatch
|
||||
>r >r 3dup between? r> r> rot [
|
||||
>r 2drop - >fixnum r> dispatch
|
||||
] [
|
||||
2drop r> call r> drop
|
||||
drop 2nip call
|
||||
] if ; inline
|
||||
|
||||
: dispatch-case-quot ( default assoc -- quot )
|
||||
|
|
|
@ -34,10 +34,10 @@ GENERIC: engine>quot ( engine -- quot )
|
|||
[ [ nip class<= ] curry assoc-filter ] 2bi ;
|
||||
|
||||
: convert-methods ( assoc class word -- assoc' )
|
||||
over >r >r split-methods dup assoc-empty? [
|
||||
r> r> 3drop
|
||||
over [ split-methods ] 2dip pick assoc-empty? [
|
||||
3drop
|
||||
] [
|
||||
r> execute r> pick set-at
|
||||
[ execute ] dip pick set-at
|
||||
] if ; inline
|
||||
|
||||
: (picker) ( n -- quot )
|
||||
|
|
|
@ -61,8 +61,8 @@ M: decoder stream-read1
|
|||
: (read) ( n quot -- n string )
|
||||
over 0 <string> [
|
||||
[
|
||||
>r call dup
|
||||
[ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
|
||||
slip over
|
||||
[ swapd set-nth-unsafe f ] [ 3drop t ] if
|
||||
] 2curry find-integer
|
||||
] keep ; inline
|
||||
|
||||
|
|
|
@ -96,8 +96,8 @@ PRIVATE>
|
|||
|
||||
: integer, ( num radix -- )
|
||||
dup 1 <= [ "Invalid radix" throw ] when
|
||||
dup >r /mod >digit , dup 0 >
|
||||
[ r> integer, ] [ r> 2drop ] if ;
|
||||
[ /mod >digit , ] keep over 0 >
|
||||
[ integer, ] [ 2drop ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -33,7 +33,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
|
|||
: first ( seq -- first ) 0 swap nth ; inline
|
||||
: second ( seq -- second ) 1 swap nth ; inline
|
||||
: third ( seq -- third ) 2 swap nth ; inline
|
||||
: fourth ( seq -- fourth ) 3 swap nth ; inline
|
||||
: fourth ( seq -- fourth ) 3 swap nth ; inline
|
||||
|
||||
: set-first ( first seq -- ) 0 swap set-nth ; inline
|
||||
: set-second ( second seq -- ) 1 swap set-nth ; inline
|
||||
|
@ -173,13 +173,6 @@ M: reversed length seq>> length ;
|
|||
|
||||
INSTANCE: reversed virtual-sequence
|
||||
|
||||
: reverse ( seq -- newseq )
|
||||
[
|
||||
dup [ length ] keep new-sequence
|
||||
[ 0 swap copy ] keep
|
||||
[ reverse-here ] keep
|
||||
] keep like ;
|
||||
|
||||
! A slice of another sequence.
|
||||
TUPLE: slice
|
||||
{ from read-only }
|
||||
|
@ -341,11 +334,10 @@ M: immutable-sequence clone-like like ;
|
|||
pick >r >r (each) r> call r> finish-find ; inline
|
||||
|
||||
: (find-from) ( n seq quot quot' -- i elt )
|
||||
>r >r 2dup bounds-check? [
|
||||
r> r> (find)
|
||||
] [
|
||||
r> r> 2drop 2drop f f
|
||||
] if ; inline
|
||||
[ 2dup bounds-check? ] 2dip
|
||||
[ (find) ] 2curry
|
||||
[ 2drop f f ]
|
||||
if ; inline
|
||||
|
||||
: (monotonic) ( seq quot -- ? )
|
||||
[ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
|
||||
|
@ -609,6 +601,13 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
tuck - 1- rot exchange-unsafe
|
||||
] each 2drop ;
|
||||
|
||||
: reverse ( seq -- newseq )
|
||||
[
|
||||
dup [ length ] keep new-sequence
|
||||
[ 0 swap copy ] keep
|
||||
[ reverse-here ] keep
|
||||
] keep like ;
|
||||
|
||||
: sum-lengths ( seq -- n )
|
||||
0 [ length + ] reduce ;
|
||||
|
||||
|
@ -632,8 +631,10 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
] keep like ;
|
||||
|
||||
: padding ( seq n elt quot -- newseq )
|
||||
>r >r over length [-] dup zero?
|
||||
[ r> r> 3drop ] [ r> <repetition> r> call ] if ; inline
|
||||
[
|
||||
[ over length [-] dup zero? [ drop ] ] dip
|
||||
[ <repetition> ] curry
|
||||
] dip compose if ; inline
|
||||
|
||||
: pad-left ( seq n elt -- padded )
|
||||
[ swap dup (append) ] padding ;
|
||||
|
@ -738,9 +739,11 @@ PRIVATE>
|
|||
[ left-trim ] [ right-trim ] bi ; inline
|
||||
|
||||
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
|
||||
|
||||
: product ( seq -- n ) 1 [ * ] binary-reduce ;
|
||||
|
||||
: infimum ( seq -- n ) dup first [ min ] reduce ;
|
||||
|
||||
: supremum ( seq -- n ) dup first [ max ] reduce ;
|
||||
|
||||
: flip ( matrix -- newmatrix )
|
||||
|
@ -752,4 +755,3 @@ PRIVATE>
|
|||
: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
|
||||
|
||||
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
|
||||
|
||||
|
|
|
@ -25,19 +25,19 @@ TUPLE: merge
|
|||
|
||||
: dump ( from to seq accum -- )
|
||||
#! Optimize common case where to - from = 1, 2, or 3.
|
||||
>r >r 2dup swap - dup 1 =
|
||||
[ 2drop r> nth-unsafe r> push ] [
|
||||
dup 2 = [
|
||||
2drop dup 1+
|
||||
>r >r 2dup swap - r> r> pick 1 =
|
||||
[ >r >r 2drop r> nth-unsafe r> push ] [
|
||||
pick 2 = [
|
||||
>r >r 2drop dup 1+
|
||||
r> [ nth-unsafe ] curry bi@
|
||||
r> [ push ] curry bi@
|
||||
] [
|
||||
dup 3 = [
|
||||
2drop dup 1+ dup 1+
|
||||
pick 3 = [
|
||||
>r >r 2drop dup 1+ dup 1+
|
||||
r> [ nth-unsafe ] curry tri@
|
||||
r> [ push ] curry tri@
|
||||
] [
|
||||
drop r> subseq r> push-all
|
||||
>r nip subseq r> push-all
|
||||
] if
|
||||
] if
|
||||
] if ; inline
|
||||
|
@ -120,11 +120,13 @@ TUPLE: merge
|
|||
[ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
|
||||
|
||||
: (sort-pairs) ( i1 i2 seq quot accum -- )
|
||||
>r >r 2dup length = [
|
||||
nip nth r> drop r> push
|
||||
[ 2dup length = ] 2dip rot [
|
||||
[ drop nip nth ] dip push
|
||||
] [
|
||||
tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq?
|
||||
[ swap ] when r> tuck [ push ] 2bi@
|
||||
[
|
||||
[ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq?
|
||||
[ swap ] when
|
||||
] dip tuck [ push ] 2bi@
|
||||
] if ; inline
|
||||
|
||||
: sort-pairs ( merge quot -- )
|
||||
|
|
Loading…
Reference in New Issue