Fix ambiguity between 'initial: f' and no initial value in a slot spec. Fixes #382

basis/classes/struct/struct.factor

@@ -149,7 +149,7 @@ M: struct-class boa>object
     [ <struct> ] [ struct-slots ] bi
     [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
 
-M: struct-class initial-value* <struct> ; inline
+M: struct-class initial-value* <struct> t ; inline
 
 ! Struct slot accessors
 

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

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
+

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 } ;

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 ] }
+        { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
-        { [ \ f bootstrap-word over class<= ] [ f ] }
+        { [ \ f bootstrap-word over class<= ] [ f t ] }
-        { [ \ array-capacity bootstrap-word over class<= ] [ 0 ] }
+        { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
-        { [ float bootstrap-word over class<= ] [ 0.0 ] }
+        { [ float bootstrap-word over class<= ] [ 0.0 t ] }
-        { [ string bootstrap-word over class<= ] [ "" ] }
+        { [ string bootstrap-word over class<= ] [ "" t ] }
-        { [ array bootstrap-word over class<= ] [ { } ] }
+        { [ array bootstrap-word over class<= ] [ { } t ] }
-        { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
+        { [ byte-array bootstrap-word over class<= ] [ B{ } t ] }
-        { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> ] }
+        { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
-        { [ quotation bootstrap-word over class<= ] [ [ ] ] }
+        { [ 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
+    ] if-bootstrapping ;
-    ] [
-        dup class>> initial-value >>initial
-    ] if ;
 
 M: array make-slot
     <slot-spec>