Merge branch 'master' into new_optimizer

db4
Slava Pestov 2008-08-18 20:31:57 -05:00
commit 60dd301497
7 changed files with 45 additions and 45 deletions

View File

@ -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 ;

View File

@ -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 )

View File

@ -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 )

View File

@ -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

View File

@ -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>

View File

@ -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

View File

@ -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 -- )