tuples gracefully handle changing shape

TODO.FACTOR.txt

@@ -1,6 +1,5 @@
 72/73:
 
-- tuples: gracefully handle changing shape
 - keep a list of getter/setter words
 - default constructor
 - move tuple to generic vocab

library/compiler/alien-types.factor

@@ -53,13 +53,13 @@ namespaces parser strings words ;
 : define-getter ( offset type name -- )
     #! Define a word with stack effect ( alien -- obj ) in the
     #! current 'in' vocabulary.
-    "in" get create >r
+    create-in >r
     [ "getter" get ] bind cons r> swap define-compound ;
 
 : define-setter ( offset type name -- )
     #! Define a word with stack effect ( obj alien -- ) in the
     #! current 'in' vocabulary.
-    "set-" swap cat2 "in" get create >r
+    "set-" swap cat2 create-in >r
     [ "setter" get ] bind cons r> swap define-compound ;
 
 : define-field ( offset type name -- offset )
@@ -78,7 +78,7 @@ namespaces parser strings words ;
     #! Used for C functions that expect you to pass in a struct.
     [ <local-alien> ] cons
     [ "<" , "struct-name" get , ">" , ] make-string
-    "in" get create swap
+    create-in swap
     define-compound ;
 
 : define-struct-type ( width -- )

library/generic/generic.factor

@@ -7,7 +7,7 @@ namespaces parser strings words vectors math math-internals ;
 ! A simple single-dispatch generic word system.
 
 : predicate-word ( word -- word )
-    word-name "?" cat2 "in" get create ;
+    word-name "?" cat2 create-in ;
 
 ! Terminology:
 ! - type: a datatype built in to the runtime, eg fixnum, word

library/generic/tuple.factor

@@ -29,15 +29,27 @@ kernel-internals math hashtables errors vectors ;
     over >r [ single-combination ] \ GENERIC: r> define-generic
     define-method ;
 
-: define-accessor ( word name n -- )
-    >r [ >r dup word-name , "-" , r> , ] make-string
-    "in" get create  r> [ slot ] cons define-tuple-generic ;
+: accessor-word ( name tuple -- word )
+    [ word-name , "-" , , ] make-string
+    create-in ;
 
-: define-mutator ( word name n -- )
-    >r [ "set-" , >r dup word-name , "-" , r> , ] make-string
-    "in" get create  r> [ set-slot ] cons define-tuple-generic ;
+: define-accessor ( tuple name n -- accessor )
+    #! Generic word with a method specializing on the tuple's
+    #! class that reads the right slot.
+    >r over accessor-word  r> [ slot ] cons
+    define-tuple-generic ;
 
-: define-field ( word name n -- )
+: mutator-word ( name tuple -- word )
+    [ "set-" , word-name , "-" , , ] make-string
+    create-in ;
+
+: define-mutator ( word name n -- mutator )
+    #! Generic word with a method specializing on the tuple's
+    #! class that writes to the right slot.
+    >r over mutator-word  r> [ set-slot ] cons
+    define-tuple-generic ;
+
+: define-slot ( word name n -- )
     over "delegate" = [
         pick over "delegate-field" set-word-property
     ] when
@@ -50,43 +62,54 @@ kernel-internals math hashtables errors vectors ;
     [ swap dup tuple? [ class eq? ] [ 2drop f ] ifte ] cons
     define-compound ;
 
-: define-tuple ( word fields -- )
-    2dup length 1 + "tuple-size" set-word-property
-    dup length [ 3 + ] project zip
-    [ uncons define-field ] each-with ;
-
 : begin-tuple ( word -- )
     dup intern-symbol
     dup tuple-predicate
     dup define-promise
     tuple "metaclass" set-word-property ;
 
+: check-shape ( word slots -- )
+    #! If the new list of slots is different from the previous,
+    #! forget the old definition.
+    >r "use" get search dup [
+        dup "slots" word-property r> = [
+            drop
+        ] [
+            forget
+        ] ifte
+    ] [
+        r> 2drop
+    ] ifte ;
+
+: define-slots ( tuple slots -- )
+    2dup "slots" set-word-property
+    2dup length 1 + "tuple-size" set-word-property
+    dup length [ 3 + ] project zip
+    [ uncons define-slot ] each-with ;
+
+: define-tuple ( tuple slots -- )
+    2dup check-shape
+    >r
+    create-in dup save-location
+    dup begin-tuple
+    r>
+    define-slots ;
+
 : TUPLE:
-    #! Followed by a tuple name, then field names, then ;
-    CREATE dup begin-tuple
+    #! Followed by a tuple name, then slot names, then ;
+    scan
     string-mode on
     [ string-mode off define-tuple ]
     f ; parsing
 
 : constructor-word ( word -- word )
-    word-name "<" swap ">" cat3 "in" get create ;
+    word-name "<" swap ">" cat3 create-in ;
 
 : tuple-constructor ( word def -- )
     over constructor-word >r
     [ swap literal, \ make-tuple , append, ] make-list
     r> swap define-compound ;
 
-: wrapper-constructor ( word -- quot )
-    "delegate-field" word-property [ set-slot ] cons
-    [ keep ] cons ;
-
-: WRAPPER:
-    #! A wrapper is a tuple whose only slot is a delegate slot.
-    CREATE dup begin-tuple
-    dup [ "delegate" ] define-tuple
-    dup wrapper-constructor
-    tuple-constructor ; parsing
-
 : C:
     #! Followed by a tuple name, then constructor code, then ;
     #! Constructor code executes with the empty tuple on the

library/io/ansi.factor

@@ -48,7 +48,9 @@ presentation generic ;
 : ansi-attr-string ( string style -- string )
     [ ansi-attrs , reset , ] make-string ;
 
-WRAPPER: ansi-stream
+TUPLE: ansi-stream delegate ;
+C: ansi-stream ( delegate -- stream )
+    [ set-ansi-stream-delegate ] keep ;
 
 M: ansi-stream fwrite-attr ( string style stream -- )
     >r [ default-style ] unless* ansi-attr-string r>

library/io/stdio.factor

@@ -29,7 +29,9 @@ SYMBOL: stdio
         call stdio get stream>str
     ] with-stream ;
 
-WRAPPER: stdio-stream
+TUPLE: stdio-stream delegate ;
+C: stdio-stream ( delegate -- stream )
+    [ set-stdio-stream-delegate ] keep ;
 
 M: stdio-stream fauto-flush ( -- )
     stdio-stream-delegate fflush ;

library/syntax/parser.factor

@@ -1,39 +1,8 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004, 2005 Slava Pestov.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
 IN: parser
-USE: errors
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: strings
-USE: words
-USE: unparser
+USING: errors kernel lists math namespaces strings words
+unparser ;
 
 ! The parser uses a number of variables:
 ! line - the line being parsed
@@ -137,13 +106,17 @@ global [ string-mode off ] bind
     #! the parser is already line-tokenized.
     (until-eol) (until) ;
 
-: CREATE ( -- word )
-    scan "in" get create dup set-word
-    dup f "documentation" set-word-property
-    dup f "stack-effect" set-word-property
+: save-location ( word -- )
+    #! Remember where this word was defined.
+    dup set-word
     dup "line-number" get "line" set-word-property
-    dup "col"         get "col"  set-word-property
-    dup "file"        get "file" set-word-property ;
+    dup "col" get "col"  set-word-property
+    "file" get "file" set-word-property ;
+
+: create-in "in" get create ;
+
+: CREATE ( -- word )
+    scan create-in dup save-location ;
 
 : escape ( ch -- esc )
     [

library/test/tuple.factor

@@ -1,5 +1,5 @@
 IN: scratchpad
-USING: generic kernel test math ;
+USING: generic kernel test math parser ;
 
 TUPLE: rect x y w h ;
 C: rect
@@ -20,7 +20,9 @@ M: object delegation-test drop 3 ;
 TUPLE: quux-tuple ;
 C: quux-tuple ;
 M: quux-tuple delegation-test drop 4 ;
-WRAPPER: quuux-tuple
+TUPLE: quuux-tuple delegate ;
+C: quuux-tuple
+    [ set-quuux-tuple-delegate ] keep ;
 
 [ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
 
@@ -28,6 +30,24 @@ GENERIC: delegation-test-2
 TUPLE: quux-tuple-2 ;
 C: quux-tuple-2 ;
 M: quux-tuple-2 delegation-test-2 drop 4 ;
-WRAPPER: quuux-tuple-2
+TUPLE: quuux-tuple-2 delegate ;
+C: quuux-tuple-2
+    [ set-quuux-tuple-2-delegate ] keep ;
 
 [ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
+
+! Make sure we handle changing shapes!
+
+[
+    100
+] [
+    TUPLE: point x y ;
+    C: point [ set-point-y ] keep [ set-point-x ] keep ;
+    
+    100 200 <point>
+    
+    ! Use eval to sequence parsing explicitly
+    "TUPLE: point y x ;" eval
+    
+    point-x
+] unit-test

library/vocabularies.factor

@@ -57,7 +57,13 @@ IN: words USING: hashtables kernel lists namespaces strings ;
     #! Create a new word in a vocabulary. If the vocabulary
     #! already contains the word, the existing instance is
     #! returned.
-    2dup (search) [ nip ] [ (create) dup reveal ] ?ifte ;
+    2dup (search) [
+        nip
+        dup f "documentation" set-word-property
+        dup f "stack-effect" set-word-property
+    ] [
+        (create) dup reveal
+    ] ?ifte ;
 
 : forget ( word -- )
     #! Remove a word definition.