decouple struct parsing/printing from tuple parsing/printing a bit

diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor
index 39a2d5f3dc96f0f0b01de3f8535cf95f1bd5b02a..6b1e839ca6d47173c0b15907c9b314e369683983 100755 (executable)
--- a/basis/inverse/inverse.factor
+++ b/basis/inverse/inverse.factor
@@ -248,7 +248,7 @@ DEFER: __
     "predicate" word-prop [ dupd call assure ] curry ;
 
 : slot-readers ( class -- quot )
-    class-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
+    all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
 
 : ?wrapped ( object -- wrapped )
     dup wrapper? [ wrapped>> ] when ;
@@ -295,4 +295,4 @@ M: no-match summary drop "Fall through in switch" ;
     reverse [ [ [undo] ] dip compose ] { } assoc>map
     recover-chain ;
 
-MACRO: switch ( quot-alist -- ) [switch] ;
\ No newline at end of file
+MACRO: switch ( quot-alist -- ) [switch] ;

diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 2f87e5ab057aa0a6a1ce07215c0676b16a01d1a3..247067673e3d1ec7bfa2acb71ec1d4633e95d2f3 100644 (file)
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -124,29 +124,31 @@ M: pathname pprint*
         ] if
     ] if ; inline
 
-: tuple>assoc ( tuple -- assoc )
-    [ class class-slots ] [ object-slots ] bi zip
+: filter-tuple-assoc ( slot,value -- name,value )
     [ [ initial>> ] dip = not ] assoc-filter
     [ [ name>> ] dip ] assoc-map ;
 
+: tuple>assoc ( tuple -- assoc )
+    [ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
+
 : pprint-slot-value ( name value -- )
     <flow \ { pprint-word
     [ text ] [ f <inset pprint* block> ] bi*
     \ } pprint-word block> ;
 
+: (pprint-tuple) ( opener class slots closer -- )
+    <flow {
+        [ pprint-word ]
+        [ pprint-word ]
+        [ t <inset [ pprint-slot-value ] assoc-each block> ]
+        [ pprint-word ]
+    } spread block> ;
+
+: ?pprint-tuple ( tuple quot -- )
+    [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
+
 : pprint-tuple ( tuple -- )
-    boa-tuples? get [ pprint-object ] [
-        [
-            <flow
-            dup pprint-delims drop pprint-word
-            dup class pprint-word
-            t <inset
-            dup tuple>assoc [ pprint-slot-value ] assoc-each
-            block>
-            pprint-delims nip pprint-word
-            block>
-        ] check-recursion
-    ] if ;
+    [ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
 
 M: tuple pprint*
     pprint-tuple ;
@@ -186,7 +188,7 @@ M: callstack >pprint-sequence callstack>array ;
     [ 1array ] [ [ f 2array ] dip append ] if-empty ;
 
 M: tuple >pprint-sequence
-    [ class ] [ object-slots ] bi class-slot-sequence ;
+    [ class ] [ tuple-slots ] bi class-slot-sequence ;
 
 M: object pprint-narrow? drop f ;
 M: byte-vector pprint-narrow? drop f ;

diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index 39a5d56f71b9bde7fa3f9b8a6e1297c816b8db00..7ba850f744da3ee144fb31f3ab116371bbb84fcf 100644 (file)
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -92,19 +92,19 @@ GENERIC# boa>object 1 ( class slots -- tuple )
 M: tuple-class boa>object
     swap prefix >tuple ;
 
-: assoc>object ( class slots -- tuple )
-    [ [ ] [ initial-values ] [ class-slots ] tri ] dip
+: assoc>object ( class slots values -- tuple )
+    [ [ [ initial>> ] map ] keep ] dip
     swap [ [ slot-named* drop ] curry dip ] curry assoc-map
     [ dup <enum> ] dip update boa>object ;
 
-: parse-tuple-literal-slots ( class -- tuple )
+: parse-tuple-literal-slots ( class slots -- tuple )
     scan {
         { f [ unexpected-eof ] }
-        { "f" [ \ } parse-until boa>object ] }
+        { "f" [ drop \ } parse-until boa>object ] }
         { "{" [ parse-slot-values assoc>object ] }
-        { "}" [ new ] }
+        { "}" [ drop new ] }
         [ bad-literal-tuple ]
     } case ;
 
 : parse-tuple-literal ( -- tuple )
-    scan-word parse-tuple-literal-slots ;
+    scan-word dup all-slots parse-tuple-literal-slots ;

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 1452abd4b47bcb182fff5c3115663e0f9428fc2c..0a437a3d6968918670a40cd91ebc7e5f4dae8fe5 100755 (executable)
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -18,11 +18,6 @@ ERROR: not-a-tuple object ;
 : all-slots ( class -- slots )
     superclasses [ "slots" word-prop ] map concat ;
 
-GENERIC: class-slots ( class -- slots )
-
-M: tuple-class class-slots
-    all-slots ;
-
 PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
     all-slots [ read-only>> ] all? ;
 
@@ -55,14 +50,11 @@ M: tuple class layout-of 2 slot { word } declare ; inline
 
 PRIVATE>
 
-: tuple-initial-values ( class -- slots )
-    all-slots [ initial>> ] map ;
-
 : initial-values ( class -- slots )
-    class-slots [ initial>> ] map ;
+    all-slots [ initial>> ] map ;
 
 : pad-slots ( slots class -- slots' class )
-    [ tuple-initial-values over length tail append ] keep ; inline
+    [ initial-values over length tail append ] keep ; inline
 
 : tuple>array ( tuple -- array )
     prepare-tuple>array
@@ -72,10 +64,6 @@ PRIVATE>
 : tuple-slots ( tuple -- seq )
     prepare-tuple>array drop copy-tuple-slots ;
 
-GENERIC: object-slots ( object -- seq )
-M: tuple object-slots
-    tuple-slots ;
-
 GENERIC: slots>tuple ( seq class -- tuple )
 
 M: tuple-class slots>tuple ( seq class -- tuple )
@@ -159,7 +147,7 @@ ERROR: bad-superclass class ;
     dup boa-check-quot "boa-check" set-word-prop ;
 
 : tuple-prototype ( class -- prototype )
-    [ tuple-initial-values ] keep over [ ] any?
+    [ initial-values ] keep over [ ] any?
     [ slots>tuple ] [ 2drop f ] if ;
 
 : define-tuple-prototype ( class -- )

diff --git a/extra/classes/struct/prettyprint/prettyprint.factor b/extra/classes/struct/prettyprint/prettyprint.factor
index b63f153b16611c23bc2b3b60e79159dd5ca6c128..517aa343c6df7016124ca09de678064b5e34f978 100644 (file)
--- a/extra/classes/struct/prettyprint/prettyprint.factor
+++ b/extra/classes/struct/prettyprint/prettyprint.factor
@@ -3,11 +3,28 @@ USING: classes.struct kernel prettyprint.backend prettyprint.custom
 prettyprint.sections see.private sequences words ;
 IN: classes.struct.prettyprint
 
+<PRIVATE
+
+: struct-definer-word ( class -- word )
+    struct-slots dup length 2 >=
+    [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
+    [ drop \ STRUCT: ] if ;
+
+: struct>assoc ( struct -- assoc )
+    [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
+
+PRIVATE>
+
 M: struct-class see-class*
-    <colon \ STRUCT: pprint-word dup pprint-word
-    <block "struct-slots" word-prop [ pprint-slot ] each
+    <colon dup struct-definer-word pprint-word dup pprint-word
+    <block struct-slots [ pprint-slot ] each
     block> pprint-; block> ;
 
 M: struct pprint-delims
     drop \ S{ \ } ;
 
+M: struct >pprint-sequence
+    [ class ] [ struct-slot-values ] bi class-slot-sequence ;
+
+M: struct pprint*
+    [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;

diff --git a/extra/classes/struct/struct-docs.factor b/extra/classes/struct/struct-docs.factor
index 90247a04958cb93401135d0a1c48ed5483e127b1..83d5859f7c5580ff0e671998de5cb0305ab406e0 100644 (file)
--- a/extra/classes/struct/struct-docs.factor
+++ b/extra/classes/struct/struct-docs.factor
@@ -31,7 +31,7 @@ HELP: STRUCT:
 HELP: S{
 { $syntax "S{ class slots... }" }
 { $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
-{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; in fact, " { $snippet "T{" } " and " { $snippet "S{" } " can be used interchangeably. Structs will always be printed with " { $snippet "S{" } "." } ;
+{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
 
 HELP: UNION-STRUCT:
 { $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }

diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index d52c25e413a34e16e8c64d005941fa229d407aa6..2b2aa49aeb3087b7fbd5b8a3e228520960d7cd15 100644 (file)
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -15,6 +15,9 @@ TUPLE: struct
 PREDICATE: struct-class < tuple-class
     \ struct subclass-of? ;
 
+M: struct-class struct-slots
+    "struct-slots" word-prop ;
+
 ! struct allocation
 
 M: struct >c-ptr
@@ -38,7 +41,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
     [
         [ <wrapper> \ (struct) [ ] 2sequence ]
         [
-            "struct-slots" word-prop
+            struct-slots
             [ length \ ndip ]
             [ [ name>> setter-word 1quotation ] map \ spread ] bi
         ] bi
@@ -53,11 +56,13 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 
 M: struct-class boa>object
     swap pad-struct-slots
-    [ (struct) ] [ "struct-slots" word-prop ] bi 
+    [ (struct) ] [ struct-slots ] bi 
     [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
 
 ! Struct slot accessors
 
+GENERIC: struct-slot-values ( struct -- sequence )
+
 M: struct-class reader-quot
     nip
     [ class>> c-type-getter-boxer ]
@@ -66,18 +71,15 @@ M: struct-class reader-quot
 M: struct-class writer-quot
     nip (writer-quot) ;
 
-M: struct-class class-slots
-    "struct-slots" word-prop ;
-
-: object-slots-quot ( class -- quot )
-    "struct-slots" word-prop
+: struct-slot-values-quot ( class -- quot )
+    struct-slots
     [ name>> reader-word 1quotation ] map
     \ cleave [ ] 2sequence
     \ output>array [ ] 2sequence ;
 
-: (define-object-slots-method) ( class -- )
-    [ \ object-slots create-method-in ]
-    [ object-slots-quot ] bi define ;
+: (define-struct-slot-values-method) ( class -- )
+    [ \ struct-slot-values create-method-in ]
+    [ struct-slot-values-quot ] bi define ;
 
 ! Struct as c-type
 
@@ -125,7 +127,7 @@ M: struct-class direct-array-of
 : struct-prototype ( class -- prototype )
     [ heap-size <byte-array> ]
     [ memory>struct ]
-    [ "struct-slots" word-prop ] tri
+    [ struct-slots ] tri
     [
         [ initial>> ]
         [ (writer-quot) ] bi
@@ -134,14 +136,14 @@ M: struct-class direct-array-of
 
 : (struct-word-props) ( class slots size align -- )
     [
-        [ "struct-slots" set-word-prop ]
+        [ struct-slots ]
         [ define-accessors ] 2bi
     ]
     [ "struct-size" set-word-prop ]
     [ "struct-align" set-word-prop ] tri-curry*
     [ tri ] 3curry
     [ dup struct-prototype "prototype" set-word-prop ]
-    [ (define-object-slots-method) ] tri ;
+    [ (define-struct-slot-values-method) ] tri ;
 
 : check-struct-slots ( slots -- )
     [ class>> c-type drop ] each ;
@@ -172,5 +174,4 @@ USING: vocabs vocabs.loader ;
 "prettyprint" vocab [ "classes.struct.prettyprint" require ] when
 
 SYNTAX: S{
-    POSTPONE: T{ ;
-
+    scan-word dup struct-slots parse-tuple-literal-slots ;