Throw error if superclass is not a tuple class
parent
9a734b74ce
commit
5fda0ed040
|
@ -538,3 +538,6 @@ TUPLE: another-forget-accessors-test ;
|
||||||
] with-string-writer empty?
|
] with-string-writer empty?
|
||||||
] with-variable
|
] with-variable
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Missing error check
|
||||||
|
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
||||||
|
|
|
@ -58,6 +58,8 @@ PRIVATE>
|
||||||
: all-slot-names ( class -- slots )
|
: all-slot-names ( class -- slots )
|
||||||
superclasses [ slot-names ] map concat \ class prefix ;
|
superclasses [ slot-names ] map concat \ class prefix ;
|
||||||
|
|
||||||
|
ERROR: bad-superclass class ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: tuple= ( tuple1 tuple2 -- ? )
|
: tuple= ( tuple1 tuple2 -- ? )
|
||||||
|
@ -185,16 +187,23 @@ M: tuple-class update-class
|
||||||
: tuple-class-unchanged? ( class superclass slots -- ? )
|
: tuple-class-unchanged? ( class superclass slots -- ? )
|
||||||
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
|
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
|
||||||
|
|
||||||
|
: valid-superclass? ( class -- ? )
|
||||||
|
[ tuple-class? ] [ tuple bootstrap-word eq? ] bi or ;
|
||||||
|
|
||||||
|
: check-superclass ( superclass -- )
|
||||||
|
dup valid-superclass? [ bad-superclass ] unless drop ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
GENERIC# define-tuple-class 2 ( class superclass slots -- )
|
GENERIC# define-tuple-class 2 ( class superclass slots -- )
|
||||||
|
|
||||||
M: word define-tuple-class
|
M: word define-tuple-class
|
||||||
|
over check-superclass
|
||||||
define-new-tuple-class ;
|
define-new-tuple-class ;
|
||||||
|
|
||||||
M: tuple-class define-tuple-class
|
M: tuple-class define-tuple-class
|
||||||
3dup tuple-class-unchanged?
|
3dup tuple-class-unchanged?
|
||||||
[ 3dup redefine-tuple-class ] unless
|
[ over check-superclass 3dup redefine-tuple-class ] unless
|
||||||
3drop ;
|
3drop ;
|
||||||
|
|
||||||
: define-error-class ( class superclass slots -- )
|
: define-error-class ( class superclass slots -- )
|
||||||
|
|
|
@ -215,7 +215,10 @@ M: check-method summary
|
||||||
drop "Invalid parameters for create-method" ;
|
drop "Invalid parameters for create-method" ;
|
||||||
|
|
||||||
M: no-tuple-class summary
|
M: no-tuple-class summary
|
||||||
drop "Invalid class for define-constructor" ;
|
drop "BOA constructors can only be defined for tuple classes" ;
|
||||||
|
|
||||||
|
M: bad-superclass summary
|
||||||
|
drop "Tuple classes can only inherit from other tuple classes" ;
|
||||||
|
|
||||||
M: no-cond summary
|
M: no-cond summary
|
||||||
drop "Fall-through in cond" ;
|
drop "Fall-through in cond" ;
|
||||||
|
|
Loading…
Reference in New Issue