diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 91081a2c2e..9553cb58fd 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -149,7 +149,7 @@ M: struct-class boa>object [ ] [ struct-slots ] bi [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; -M: struct-class initial-value* ; inline +M: struct-class initial-value* t ; inline ! Struct slot accessors diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 12a4226b2c..931f6d9d32 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -64,7 +64,7 @@ must-fail-with 2 [ [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval( -- ) ] - [ error>> no-initial-value? ] + [ error>> bad-initial-value? ] must-fail-with [ f ] [ \ foo tuple-class? ] unit-test diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 2bec1e3f83..9ac04464c7 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -818,3 +818,19 @@ TUPLE: rclasstest a b ; [ f ] [ \ rclasstest \ b<< ?lookup-method ] unit-test << \ rclasstest forget >> + +! initial: should type check +TUPLE: initial-class ; + +DEFER: initial-slot + +[ ] [ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class } ;" eval( -- ) ] unit-test + +[ t ] [ initial-slot new x>> initial-class? ] unit-test + +[ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class initial: f } ;" eval( -- ) ] +[ error>> T{ bad-initial-value f "x" } = ] must-fail-with + +[ "IN: classes.tuple.tests TUPLE: initial-slot { x initial-class initial: 3 } ;" eval( -- ) ] +[ error>> T{ bad-initial-value f "x" } = ] must-fail-with + diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 24796768c1..0bb903870e 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -77,7 +77,7 @@ $nl { $list { "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." } { "If the class is a tuple class, the initial value of the slot is a new, shared instance of the class created with " { $link new } "." } - { "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." } + { "Otherwise, a " { $link bad-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." } } "A word can be used to check if a class has an initial value or not:" { $subsections initial-value } ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 128ab4003d..26c7788933 100644 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2010 Slava Pestov. +! Copyright (C) 2005, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays byte-arrays kernel kernel.private math namespaces make sequences strings effects generic generic.standard @@ -148,25 +148,23 @@ M: object writer-quot [ define-changer ] } cleave ; -ERROR: no-initial-value class ; +GENERIC: initial-value* ( class -- object ? ) -GENERIC: initial-value* ( class -- object ) +M: class initial-value* drop f f ; -M: class initial-value* no-initial-value ; - -: initial-value ( class -- object ) +: initial-value ( class -- object ? ) { - { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop ] } - { [ \ f bootstrap-word over class<= ] [ f ] } - { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] } - { [ float bootstrap-word over class<= ] [ 0.0 ] } - { [ string bootstrap-word over class<= ] [ "" ] } - { [ array bootstrap-word over class<= ] [ { } ] } - { [ byte-array bootstrap-word over class<= ] [ B{ } ] } - { [ pinned-alien bootstrap-word over class<= ] [ ] } - { [ quotation bootstrap-word over class<= ] [ [ ] ] } + { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] } + { [ \ f bootstrap-word over class<= ] [ f t ] } + { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] } + { [ float bootstrap-word over class<= ] [ 0.0 t ] } + { [ string bootstrap-word over class<= ] [ "" t ] } + { [ array bootstrap-word over class<= ] [ { } t ] } + { [ byte-array bootstrap-word over class<= ] [ B{ } t ] } + { [ pinned-alien bootstrap-word over class<= ] [ t ] } + { [ quotation bootstrap-word over class<= ] [ [ ] t ] } [ dup initial-value* ] - } cond nip ; + } cond [ drop ] 2dip ; GENERIC: make-slot ( desc -- slot-spec ) @@ -177,10 +175,15 @@ M: string make-slot : peel-off-name ( slot-spec array -- slot-spec array ) [ first >>name ] [ rest ] bi ; inline +: init-slot-class ( slot-spec class -- slot-spec ) + [ >>class ] [ initial-value [ >>initial ] [ drop ] if ] bi ; + : peel-off-class ( slot-spec array -- slot-spec array ) dup empty? [ dup first class? [ - [ first >>class ] [ rest ] bi + [ first init-slot-class ] + [ rest ] + bi ] when ] unless ; @@ -198,14 +201,10 @@ ERROR: bad-slot-attribute key ; ERROR: bad-initial-value name ; : check-initial-value ( slot-spec -- slot-spec ) - dup initial>> [ - [ ] [ - dup [ initial>> ] [ class>> ] bi instance? - [ name>> bad-initial-value ] unless - ] if-bootstrapping - ] [ - dup class>> initial-value >>initial - ] if ; + [ ] [ + dup [ initial>> ] [ class>> ] bi instance? + [ name>> bad-initial-value ] unless + ] if-bootstrapping ; M: array make-slot