Fix two bugs

db4
Slava Pestov 2008-07-05 20:37:28 -05:00
parent 1e3cac9a86
commit 1c92b20a9a
3 changed files with 28 additions and 19 deletions

View File

@ -657,6 +657,8 @@ TUPLE: boa-coercer-test { x array-capacity } ;
[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
[ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
! Test error classes
ERROR: error-class-test a b c ;

View File

@ -17,6 +17,9 @@ ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
<PRIVATE
: (tuple) ( layout -- tuple )
@ -46,6 +49,20 @@ ERROR: not-a-tuple object ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
: check-slots ( seq class -- seq class )
[ ] [
2dup all-slots [
class>> 2dup instance?
[ 2drop ] [ bad-slot-value ] if
] 2each
] if-bootstrapping ; inline
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
PRIVATE>
: tuple>array ( tuple -- array )
@ -56,21 +73,10 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
: check-slots ( seq class -- seq class )
[ ] [
2dup all-slots [
class>> 2dup instance?
[ 2drop ] [ bad-slot-value ] if
] 2each
] if-bootstrapping ; inline
GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple
check-slots
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ]
[ [ set-array-nth ] curry ]
@ -138,8 +144,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
[ all-slots [ initial>> ] map ] keep
over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
[ initial-values ] keep
over [ ] all? [ 2drop f ] [ slots>tuple ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;

View File

@ -13,11 +13,12 @@ SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
[ compile-queue get push-front ]
} cond ;
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;