Fix erg's tuple definition bugs
Slava Pestov
parent
b887849eb9
commit
817035099c
|
|
@ -1,35 +1,44 @@
|
|||
IN: classes.tuple.parser.tests
|
||||
USING: accessors classes.tuple.parser lexer words classes
|
||||
sequences math kernel slots tools.test parser compiler.units ;
|
||||
sequences math kernel slots tools.test parser compiler.units
|
||||
arrays classes.tuple ;
|
||||
|
||||
TUPLE: test-1 ;
|
||||
|
||||
[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
|
||||
[ t ] [ test-1 "slots" word-prop empty? ] unit-test
|
||||
|
||||
TUPLE: test-2 < test-1 ;
|
||||
|
||||
[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
|
||||
[ t ] [ test-2 "slots" word-prop empty? ] unit-test
|
||||
[ test-1 ] [ test-2 superclass ] unit-test
|
||||
|
||||
TUPLE: test-3 a ;
|
||||
|
||||
[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
|
||||
[ { "a" } ] [ test-3 "slots" word-prop [ name>> ] map ] unit-test
|
||||
|
||||
[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
|
||||
|
||||
TUPLE: test-4 < test-3 b ;
|
||||
|
||||
[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
|
||||
[ { "b" } ] [ test-4 "slots" word-prop [ name>> ] map ] unit-test
|
||||
|
||||
TUPLE: test-5 { a integer } ;
|
||||
|
||||
[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
|
||||
[ { { "a" integer } } ]
|
||||
[
|
||||
test-5 "slots" word-prop
|
||||
[ [ name>> ] [ class>> ] bi 2array ] map
|
||||
] unit-test
|
||||
|
||||
TUPLE: test-6 < test-5 { b integer } ;
|
||||
|
||||
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
|
||||
|
||||
[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test
|
||||
[ { { "b" integer } } ]
|
||||
[
|
||||
test-6 "slots" word-prop
|
||||
[ [ name>> ] [ class>> ] bi 2array ] map
|
||||
] unit-test
|
||||
|
||||
TUPLE: test-7 { b integer initial: 3 } ;
|
||||
|
||||
|
|
@ -39,6 +48,8 @@ TUPLE: test-8 { b integer read-only } ;
|
|||
|
||||
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
|
||||
|
||||
DEFER: foo
|
||||
|
||||
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
|
||||
[ error>> invalid-slot-name? ]
|
||||
must-fail-with
|
||||
|
|
@ -51,17 +62,33 @@ must-fail-with
|
|||
[ error>> unexpected-eof? ]
|
||||
must-fail-with
|
||||
|
||||
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
|
||||
[ error>> no-initial-value? ]
|
||||
2 [
|
||||
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
|
||||
[ error>> no-initial-value? ]
|
||||
must-fail-with
|
||||
|
||||
[ f ] [ \ foo tuple-class? ] unit-test
|
||||
] times
|
||||
|
||||
2 [
|
||||
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
|
||||
[ error>> bad-initial-value? ]
|
||||
must-fail-with
|
||||
|
||||
[ f ] [ \ foo tuple-class? ] unit-test
|
||||
] times
|
||||
|
||||
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
|
||||
[ error>> duplicate-slot-names? ]
|
||||
must-fail-with
|
||||
|
||||
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
|
||||
[ error>> bad-initial-value? ]
|
||||
must-fail-with
|
||||
[ f ] [ \ foo tuple-class? ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
{ test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
|
||||
{ test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 foo }
|
||||
[ dup class? [ forget-class ] [ drop ] if ] each
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -4,10 +4,11 @@ USING: accessors kernel sets namespaces sequences summary parser
|
|||
lexer combinators words classes.parser classes.tuple arrays ;
|
||||
IN: classes.tuple.parser
|
||||
|
||||
: slot-names ( slots -- seq )
|
||||
[ dup array? [ first ] when ] map ;
|
||||
|
||||
: shadowed-slots ( superclass slots -- shadowed )
|
||||
[ all-slots [ name>> ] map ]
|
||||
[ [ dup array? [ first ] when ] map ]
|
||||
bi* intersect ;
|
||||
[ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
|
||||
|
||||
: check-slot-shadowing ( class superclass slots -- )
|
||||
shadowed-slots [
|
||||
|
|
@ -20,11 +21,19 @@ IN: classes.tuple.parser
|
|||
] "" make note.
|
||||
] with each ;
|
||||
|
||||
ERROR: duplicate-slot-names names ;
|
||||
|
||||
M: duplicate-slot-names summary
|
||||
drop "Duplicate slot names" ;
|
||||
|
||||
: check-duplicate-slots ( slots -- )
|
||||
slot-names duplicates
|
||||
dup empty? [ drop ] [ duplicate-slot-names ] if ;
|
||||
|
||||
ERROR: invalid-slot-name name ;
|
||||
|
||||
M: invalid-slot-name summary
|
||||
drop
|
||||
"Invalid slot name" ;
|
||||
drop "Invalid slot name" ;
|
||||
|
||||
: parse-long-slot-name ( -- )
|
||||
[ scan , \ } parse-until % ] { } make ;
|
||||
|
|
@ -38,7 +47,7 @@ M: invalid-slot-name summary
|
|||
#! : ...
|
||||
{
|
||||
{ [ dup not ] [ unexpected-eof ] }
|
||||
{ [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
|
||||
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
|
||||
{ [ dup ";" = ] [ drop f ] }
|
||||
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
|
||||
} cond ;
|
||||
|
|
@ -52,4 +61,6 @@ M: invalid-slot-name summary
|
|||
{ ";" [ tuple f ] }
|
||||
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] }
|
||||
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
|
||||
} case 3dup check-slot-shadowing ;
|
||||
} case
|
||||
dup check-duplicate-slots
|
||||
3dup check-slot-shadowing ;
|
||||
|
|
|
|||
|
|
@ -346,11 +346,9 @@ HELP: tuple
|
|||
$nl
|
||||
"Tuple classes have additional word properties:"
|
||||
{ $list
|
||||
{ { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
|
||||
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
|
||||
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
|
||||
{ { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
|
||||
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
|
||||
{ { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
|
||||
} } ;
|
||||
|
||||
HELP: define-tuple-predicate
|
||||
|
|
|
|||
|
|
@ -443,36 +443,36 @@ TUPLE: redefinition-problem-2 ;
|
|||
! Hardcore unit tests
|
||||
USE: threads
|
||||
|
||||
\ thread slot-names "slot-names" set
|
||||
\ thread "slots" word-prop "slots" set
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ thread tuple { "xxx" } "slot-names" get append
|
||||
\ thread tuple { "xxx" } "slots" get append
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
|
||||
[ 1337 sleep ] "Test" spawn drop
|
||||
|
||||
[
|
||||
\ thread tuple "slot-names" get
|
||||
\ thread tuple "slots" get
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
USE: vocabs
|
||||
|
||||
\ vocab slot-names "slot-names" set
|
||||
\ vocab "slots" word-prop "slots" set
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ vocab tuple { "xxx" } "slot-names" get append
|
||||
\ vocab tuple { "xxx" } "slots" get append
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
|
||||
all-words drop
|
||||
|
||||
[
|
||||
\ vocab tuple "slot-names" get
|
||||
\ vocab tuple "slots" get
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -74,9 +74,6 @@ M: tuple-class slots>tuple
|
|||
: >tuple ( seq -- tuple )
|
||||
unclip slots>tuple ;
|
||||
|
||||
: slot-names ( class -- seq )
|
||||
"slot-names" word-prop ;
|
||||
|
||||
ERROR: bad-superclass class ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -104,7 +101,7 @@ ERROR: bad-superclass class ;
|
|||
|
||||
: superclass-size ( class -- n )
|
||||
superclasses but-last-slice
|
||||
[ slot-names length ] sigma ;
|
||||
[ "slots" word-prop length ] sigma ;
|
||||
|
||||
: (instance-check-quot) ( class -- quot )
|
||||
[
|
||||
|
|
@ -138,19 +135,18 @@ ERROR: bad-superclass class ;
|
|||
: define-tuple-prototype ( class -- )
|
||||
dup tuple-prototype "prototype" set-word-prop ;
|
||||
|
||||
: generate-tuple-slots ( class slots -- slot-specs )
|
||||
over superclass-size 2 + make-slots deprecated-slots ;
|
||||
: finalize-tuple-slots ( class slots -- slots )
|
||||
over superclass-size 2 + finalize-slots deprecated-slots ;
|
||||
|
||||
: define-tuple-slots ( class -- )
|
||||
dup dup "slot-names" word-prop generate-tuple-slots
|
||||
[ "slots" set-word-prop ]
|
||||
dup dup "slots" word-prop finalize-tuple-slots
|
||||
[ define-accessors ] ! new
|
||||
[ define-slots ] ! old
|
||||
2tri ;
|
||||
2bi ;
|
||||
|
||||
: make-tuple-layout ( class -- layout )
|
||||
[ ]
|
||||
[ [ superclass-size ] [ slot-names length ] bi + ]
|
||||
[ [ superclass-size ] [ "slots" word-prop length ] bi + ]
|
||||
[ superclasses dup length 1- ] tri
|
||||
<tuple-layout> ;
|
||||
|
||||
|
|
@ -211,8 +207,9 @@ M: tuple-class update-class
|
|||
} cleave ;
|
||||
|
||||
: define-new-tuple-class ( class superclass slots -- )
|
||||
make-slots
|
||||
[ drop f f tuple-class define-class ]
|
||||
[ nip "slot-names" set-word-prop ]
|
||||
[ nip "slots" set-word-prop ]
|
||||
[ 2drop update-classes ]
|
||||
3tri ;
|
||||
|
||||
|
|
@ -236,7 +233,7 @@ M: tuple-class update-class
|
|||
3bi ;
|
||||
|
||||
: tuple-class-unchanged? ( class superclass slots -- ? )
|
||||
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
|
||||
rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
|
||||
|
||||
: valid-superclass? ( class -- ? )
|
||||
[ tuple-class? ] [ tuple eq? ] bi or ;
|
||||
|
|
@ -281,7 +278,7 @@ M: tuple-class reset-class
|
|||
[ call-next-method ]
|
||||
[
|
||||
{
|
||||
"layout" "slots" "slot-names" "boa-check" "prototype"
|
||||
"layout" "slots" "boa-check" "prototype"
|
||||
} reset-props
|
||||
] bi
|
||||
] bi ;
|
||||
|
|
|
|||
|
|
@ -212,6 +212,12 @@ M: not-a-tuple summary
|
|||
M: bad-superclass summary
|
||||
drop "Tuple classes can only inherit from other tuple classes" ;
|
||||
|
||||
M: no-initial-value summary
|
||||
drop "Initial value must be provided for slots specialized to this class" ;
|
||||
|
||||
M: bad-initial-value summary
|
||||
drop "Incompatible initial value" ;
|
||||
|
||||
M: no-cond summary
|
||||
drop "Fall-through in cond" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -277,13 +277,32 @@ M: array pprint-slot-name
|
|||
f <inset unclip text pprint-elements block>
|
||||
\ } pprint-word block> ;
|
||||
|
||||
: unparse-slot ( slot-spec -- array )
|
||||
[
|
||||
dup name>> ,
|
||||
dup class>> object eq? [
|
||||
dup class>> ,
|
||||
initial: ,
|
||||
dup initial>> ,
|
||||
] unless
|
||||
dup read-only>> [
|
||||
read-only ,
|
||||
] when
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: pprint-slot ( slot-spec -- )
|
||||
unparse-slot
|
||||
dup length 1 = [ first ] when
|
||||
pprint-slot-name ;
|
||||
|
||||
M: tuple-class see-class*
|
||||
<colon \ TUPLE: pprint-word
|
||||
dup pprint-word
|
||||
dup superclass tuple eq? [
|
||||
"<" text dup superclass pprint-word
|
||||
] unless
|
||||
<block slot-names [ pprint-slot-name ] each block>
|
||||
<block "slots" word-prop [ pprint-slot ] each block>
|
||||
pprint-; block> ;
|
||||
|
||||
M: word see-class* drop ;
|
||||
|
|
|
|||
|
|
@ -188,9 +188,14 @@ M: array make-slot
|
|||
[ dup empty? not ] [ peel-off-attributes ] [ ] while drop
|
||||
check-initial-value ;
|
||||
|
||||
: make-slots ( slots base -- specs )
|
||||
over length [ + ] with map
|
||||
[ [ make-slot ] dip >>offset ] 2map ;
|
||||
M: slot-spec make-slot
|
||||
check-initial-value ;
|
||||
|
||||
: make-slots ( slots -- specs )
|
||||
[ make-slot ] map ;
|
||||
|
||||
: finalize-slots ( specs base -- specs )
|
||||
over length [ + ] with map [ >>offset ] 2map ;
|
||||
|
||||
: slot-named ( name specs -- spec/f )
|
||||
[ slot-spec-name = ] with find nip ;
|
||||
[ name>> = ] with find nip ;
|
||||
|
|
|
|||
|
|
@ -140,8 +140,6 @@ $nl
|
|||
|
||||
{ { $snippet "\"constructor\"" } { $link "tuple-constructors" } }
|
||||
|
||||
{ { $snippet "\"slot-names\"" } { $link "tuples" } }
|
||||
|
||||
{ { $snippet "\"type\"" } { $link "builtin-classes" } }
|
||||
|
||||
{ { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } }
|
||||
|
|
|
|||
Loading…
Reference in New Issue