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

Fix erg's tuple definition bugs

db4
Slava Pestov 2008-07-13 21:06:50 -05:00
parent b887849eb9
commit 817035099c
9 changed files with 110 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
core/classes/tuple/parser/parser-tests.factor
View File

@ -1,35 +1,44 @@
IN: classes.tuple.parser.tests IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes 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 ; 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 ; 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 [ test-1 ] [ test-2 superclass ] unit-test
TUPLE: test-3 a ; 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 [ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
TUPLE: test-4 < test-3 b ; 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 } ; 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 } ; TUPLE: test-6 < test-5 { b integer } ;
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test [ 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 } ; 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 [ 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 ] [ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
[ error>> invalid-slot-name? ] [ error>> invalid-slot-name? ]
must-fail-with must-fail-with
@ -51,17 +62,33 @@ must-fail-with
[ error>> unexpected-eof? ] [ error>> unexpected-eof? ]
must-fail-with must-fail-with
2 [
[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
[ error>> no-initial-value? ] [ error>> no-initial-value? ]
must-fail-with 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 ] [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
[ error>> bad-initial-value? ] [ error>> bad-initial-value? ]
must-fail-with 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
[ 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 [ dup class? [ forget-class ] [ drop ] if ] each
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test

25
core/classes/tuple/parser/parser.factor
View File

@ -4,10 +4,11 @@ USING: accessors kernel sets namespaces sequences summary parser
lexer combinators words classes.parser classes.tuple arrays ; lexer combinators words classes.parser classes.tuple arrays ;
IN: classes.tuple.parser IN: classes.tuple.parser
: slot-names ( slots -- seq )
[ dup array? [ first ] when ] map ;
: shadowed-slots ( superclass slots -- shadowed ) : shadowed-slots ( superclass slots -- shadowed )
[ all-slots [ name>> ] map ] [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
[ [ dup array? [ first ] when ] map ]
bi* intersect ;
: check-slot-shadowing ( class superclass slots -- ) : check-slot-shadowing ( class superclass slots -- )
shadowed-slots [ shadowed-slots [
@ -20,11 +21,19 @@ IN: classes.tuple.parser
] "" make note. ] "" make note.
] with each ; ] 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 ; ERROR: invalid-slot-name name ;
M: invalid-slot-name summary M: invalid-slot-name summary
drop drop "Invalid slot name" ;
"Invalid slot name" ;
: parse-long-slot-name ( -- ) : parse-long-slot-name ( -- )
[ scan , \ } parse-until % ] { } make ; [ scan , \ } parse-until % ] { } make ;
@ -38,7 +47,7 @@ M: invalid-slot-name summary
#! : ... #! : ...
{ {
{ [ dup not ] [ unexpected-eof ] } { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] } { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop f ] } { [ dup ";" = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ] [ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond ; } cond ;
@ -52,4 +61,6 @@ M: invalid-slot-name summary
{ ";" [ tuple f ] } { ";" [ tuple f ] }
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] } { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } 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 ;

4
core/classes/tuple/tuple-docs.factor
View File

@ -346,11 +346,9 @@ HELP: tuple
$nl $nl
"Tuple classes have additional word properties:" "Tuple classes have additional word properties:"
{ $list { $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 "\"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 "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
{ { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" } { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
} } ; } } ;
HELP: define-tuple-predicate HELP: define-tuple-predicate

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

@ -443,36 +443,36 @@ TUPLE: redefinition-problem-2 ;
! Hardcore unit tests ! Hardcore unit tests
USE: threads 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 define-tuple-class
] with-compilation-unit ] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop [ 1337 sleep ] "Test" spawn drop
[ [
\ thread tuple "slot-names" get \ thread tuple "slots" get
define-tuple-class define-tuple-class
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
USE: vocabs 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 define-tuple-class
] with-compilation-unit ] with-compilation-unit
all-words drop all-words drop
[ [
\ vocab tuple "slot-names" get \ vocab tuple "slots" get
define-tuple-class define-tuple-class
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test

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

@ -74,9 +74,6 @@ M: tuple-class slots>tuple
: >tuple ( seq -- tuple ) : >tuple ( seq -- tuple )
unclip slots>tuple ; unclip slots>tuple ;
: slot-names ( class -- seq )
"slot-names" word-prop ;
ERROR: bad-superclass class ; ERROR: bad-superclass class ;
<PRIVATE <PRIVATE
@ -104,7 +101,7 @@ ERROR: bad-superclass class ;
: superclass-size ( class -- n ) : superclass-size ( class -- n )
superclasses but-last-slice superclasses but-last-slice
[ slot-names length ] sigma ; [ "slots" word-prop length ] sigma ;
: (instance-check-quot) ( class -- quot ) : (instance-check-quot) ( class -- quot )
[ [
@ -138,19 +135,18 @@ ERROR: bad-superclass class ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ; dup tuple-prototype "prototype" set-word-prop ;
: generate-tuple-slots ( class slots -- slot-specs ) : finalize-tuple-slots ( class slots -- slots )
over superclass-size 2 + make-slots deprecated-slots ; over superclass-size 2 + finalize-slots deprecated-slots ;
: define-tuple-slots ( class -- ) : define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots dup dup "slots" word-prop finalize-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ] ! new [ define-accessors ] ! new
[ define-slots ] ! old [ define-slots ] ! old
2tri ; 2bi ;
: make-tuple-layout ( class -- layout ) : make-tuple-layout ( class -- layout )
[ ] [ ]
[ [ superclass-size ] [ slot-names length ] bi + ] [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
[ superclasses dup length 1- ] tri [ superclasses dup length 1- ] tri
<tuple-layout> ; <tuple-layout> ;
@ -211,8 +207,9 @@ M: tuple-class update-class
} cleave ; } cleave ;
: define-new-tuple-class ( class superclass slots -- ) : define-new-tuple-class ( class superclass slots -- )
make-slots
[ drop f f tuple-class define-class ] [ drop f f tuple-class define-class ]
[ nip "slot-names" set-word-prop ] [ nip "slots" set-word-prop ]
[ 2drop update-classes ] [ 2drop update-classes ]
3tri ; 3tri ;
@ -236,7 +233,7 @@ M: tuple-class update-class
3bi ; 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? ) : tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
: valid-superclass? ( class -- ? ) : valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ; [ tuple-class? ] [ tuple eq? ] bi or ;
@ -281,7 +278,7 @@ M: tuple-class reset-class
[ call-next-method ] [ call-next-method ]
[ [
{ {
"layout" "slots" "slot-names" "boa-check" "prototype" "layout" "slots" "boa-check" "prototype"
} reset-props } reset-props
] bi ] bi
] bi ; ] bi ;

6
core/debugger/debugger.factor
View File

@ -212,6 +212,12 @@ M: not-a-tuple summary
M: bad-superclass summary M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ; 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 M: no-cond summary
drop "Fall-through in cond" ; drop "Fall-through in cond" ;

21
core/prettyprint/prettyprint.factor
View File

@ -277,13 +277,32 @@ M: array pprint-slot-name
f <inset unclip text pprint-elements block> f <inset unclip text pprint-elements block>
\ } pprint-word 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* M: tuple-class see-class*
<colon \ TUPLE: pprint-word <colon \ TUPLE: pprint-word
dup pprint-word dup pprint-word
dup superclass tuple eq? [ dup superclass tuple eq? [
"<" text dup superclass pprint-word "<" text dup superclass pprint-word
] unless ] unless
<block slot-names [ pprint-slot-name ] each block> <block "slots" word-prop [ pprint-slot ] each block>
pprint-; block> ; pprint-; block> ;
M: word see-class* drop ; M: word see-class* drop ;

13
core/slots/slots.factor
View File

@ -188,9 +188,14 @@ M: array make-slot
[ dup empty? not ] [ peel-off-attributes ] [ ] while drop [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
check-initial-value ; check-initial-value ;
: make-slots ( slots base -- specs ) M: slot-spec make-slot
over length [ + ] with map check-initial-value ;
[ [ make-slot ] dip >>offset ] 2map ;
: 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-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ; [ name>> = ] with find nip ;

2
core/words/words-docs.factor
View File

@ -140,8 +140,6 @@ $nl
{ { $snippet "\"constructor\"" } { $link "tuple-constructors" } } { { $snippet "\"constructor\"" } { $link "tuple-constructors" } }
{ { $snippet "\"slot-names\"" } { $link "tuples" } }
{ { $snippet "\"type\"" } { $link "builtin-classes" } } { { $snippet "\"type\"" } { $link "builtin-classes" } }
{ { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } } { { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } }