steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/classes/tuple/tuple-tests.factor
View File

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

34
core/classes/tuple/tuple.factor
View File

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

11
core/generator/generator.factor
View File

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