Fix two bugs
parent
1e3cac9a86
commit
1c92b20a9a
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue