From 817035099c13c7b2b922562a226ff8b1cf6c0ad1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jul 2008 21:06:50 -0500 Subject: [PATCH] Fix erg's tuple definition bugs --- core/classes/tuple/parser/parser-tests.factor | 53 ++++++++++++++----- core/classes/tuple/parser/parser.factor | 25 ++++++--- core/classes/tuple/tuple-docs.factor | 4 +- core/classes/tuple/tuple-tests.factor | 12 ++--- core/classes/tuple/tuple.factor | 23 ++++---- core/debugger/debugger.factor | 6 +++ core/prettyprint/prettyprint.factor | 21 +++++++- core/slots/slots.factor | 13 +++-- core/words/words-docs.factor | 2 - 9 files changed, 110 insertions(+), 49 deletions(-) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index d40b71b477..6f7d4af6bc 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -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 + + diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index e9919ee992..ded0ca2a72 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -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 ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 51c175a282..0cf3091165 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -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 diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index b89abdfd82..35d4149d37 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ff8d2157da..17d8e36935 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 ; ; @@ -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 ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 6759c43094..151ef3b6e9 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -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" ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index f15106d78b..804895f6c4 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -277,13 +277,32 @@ M: array pprint-slot-name f \ } 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* + pprint-; block> ; M: word see-class* drop ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index a5b2e4b3d8..73d674782d 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -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 ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 2f0d061499..5d053b3b5e 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -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" } }