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

diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index 91081a2c2e462609e67c3ca902bbc6f34c57298b..9553cb58fd3ddaf6d685b231fd955484cd872a59 100644 (file)
--- a/basis/classes/struct/struct.factor
+++ b/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
 

diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index 12a4226b2c57b22cf02f525d6dbc8539a70831c8..931f6d9d32244cf8ee91e0a1c62204e946c99fe5 100644 (file)
--- 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 2bec1e3f83fa9cb6ab4b35399805111dd4295ece..9ac04464c7c531e3ba1aa77bba2737672649ded8 100644 (file)
--- 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 24796768c1ff533c0eef1b92f4e9ce168002e66f..0bb903870ec21eda1b06d59e8660b6dbd7820f55 100644 (file)
--- 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 128ab4003d6abb282bc37ce1a5da9c0eec085e02..26c7788933b1606d18358f1033c38836d133f276 100644 (file)
--- 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<= ] [ <bad-alien> ] }
-        { [ 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<= ] [ <bad-alien> 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
     <slot-spec>