core: trim using lists with lint.vocabs tool

[factor.git] / core / classes / tuple / parser / parser.factor

diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index 39a5d56f71b9bde7fa3f9b8a6e1297c816b8db00..eedfe0cc0a725ecdcf4ed3feb457357028c0c85e 100644 (file)
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sets namespaces make sequences parser
-lexer combinators words classes.parser classes.tuple arrays
-slots math assocs parser.notes ;
+USING: accessors arrays assocs classes.parser classes.tuple
+combinators kernel lexer make parser parser.notes sequences sets
+slots ;
 IN: classes.tuple.parser
 
 : slot-names ( slots -- seq )
@@ -31,24 +31,22 @@ ERROR: duplicate-slot-names names ;
 ERROR: invalid-slot-name name ;
 
 : parse-long-slot-name ( -- spec )
-    [ scan , \ } parse-until % ] { } make ;
+    [ scan-token , \ } parse-until % ] { } make ;
 
 : parse-slot-name-delim ( end-delim string/f -- ? )
-    #! This isn't meant to enforce any kind of policy, just
-    #! to check for mistakes of this form:
-    #!
-    #! TUPLE: blahblah foo bing
-    #!
-    #! : ...
+    ! Check for mistakes of this form:
+    !
+    ! TUPLE: blahblah foo bing
+    !
+    ! : ...
     {
-        { [ dup not ] [ unexpected-eof ] }
         { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
         { [ 2dup = ] [ drop f ] }
         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
     } cond nip ;
 
 : parse-tuple-slots-delim ( end-delim -- )
-    dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+    dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
 
 : parse-slot-name ( string/f -- ? )
     ";" swap parse-slot-name-delim ;
@@ -56,9 +54,8 @@ ERROR: invalid-slot-name name ;
 : parse-tuple-slots ( -- )
     ";" parse-tuple-slots-delim ;
 
-: parse-tuple-definition ( -- class superclass slots )
-    CREATE-CLASS
-    scan {
+: (parse-tuple-definition) ( word -- class superclass slots )
+    scan-token {
         { ";" [ tuple f ] }
         { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
@@ -66,45 +63,57 @@ ERROR: invalid-slot-name name ;
     dup check-duplicate-slots
     3dup check-slot-shadowing ;
 
+: parse-tuple-definition ( -- class superclass slots )
+    scan-new-class (parse-tuple-definition) ;
+
+
 ERROR: bad-literal-tuple ;
 
-: parse-slot-value ( -- )
-    scan scan-object 2array , scan {
-        { f [ \ } unexpected-eof ] }
+ERROR: bad-slot-name class slot ;
+
+: check-slot-name ( class slots name -- name )
+    2dup swap slot-named [ 2nip ] [ nip bad-slot-name ] if ;
+
+: parse-slot-value ( class slots -- )
+    scan-token check-slot-name scan-object 2array , scan-token {
         { "}" [ ] }
         [ bad-literal-tuple ]
     } case ;
 
-: (parse-slot-values) ( -- )
-    parse-slot-value
-    scan {
-        { f [ \ } unexpected-eof ] }
+: (parse-slot-values) ( class slots -- )
+    2dup parse-slot-value
+    scan-token {
         { "{" [ (parse-slot-values) ] }
-        { "}" [ ] }
-        [ bad-literal-tuple ]
+        { "}" [ 2drop ] }
+        [ 2nip bad-literal-tuple ]
     } case ;
 
-: parse-slot-values ( -- values )
+: parse-slot-values ( class slots -- values )
     [ (parse-slot-values) ] { } make ;
 
-GENERIC# boa>object 1 ( class slots -- tuple )
+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
-    swap [ [ slot-named* drop ] curry dip ] curry assoc-map
-    [ dup <enum> ] dip update boa>object ;
-
-: parse-tuple-literal-slots ( class -- tuple )
-    scan {
-        { f [ unexpected-eof ] }
-        { "f" [ \ } parse-until boa>object ] }
-        { "{" [ parse-slot-values assoc>object ] }
-        { "}" [ new ] }
+    swap slots>tuple ;
+
+: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
+    over [ drop ] [ 3nip bad-slot-name ] if ;
+
+: slot-named-checked ( class initials name slots -- class initials slot-spec )
+    over [ slot-named* ] dip check-slot-exists drop ;
+
+: assoc>object ( class slots values -- tuple )
+    [ [ [ initial>> ] map <enumerated> ] keep ] dip
+    swap [ [ slot-named-checked ] curry dip ] curry assoc-map
+    assoc-union! seq>> boa>object ;
+
+: parse-tuple-literal-slots ( class slots -- tuple )
+    scan-token {
+        { "f" [ drop \ } parse-until boa>object ] }
+        { "{" [ 2dup parse-slot-values assoc>object ] }
+        { "}" [ 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 ;