-! 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 ;
+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 )
ERROR: invalid-slot-name name ;
: parse-long-slot-name ( -- spec )
- [ scan , \ } parse-until % ] { } make ;
-
-: parse-slot-name ( string/f -- ? )
- #! This isn't meant to enforce any kind of policy, just
- #! to check for mistakes of this form:
- #!
- #! TUPLE: blahblah foo bing
- #!
- #! : ...
+ [ scan-token , \ } parse-until % ] { } make ;
+
+: parse-slot-name-delim ( end-delim string/f -- ? )
+ ! Check for mistakes of this form:
+ !
+ ! TUPLE: blahblah foo bing
+ !
+ ! : ...
{
- { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
- { [ dup ";" = ] [ drop f ] }
+ { [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
- } cond ;
+ } cond nip ;
+
+: parse-tuple-slots-delim ( end-delim -- )
+ dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+
+: parse-slot-name ( string/f -- ? )
+ ";" swap parse-slot-name-delim ;
: parse-tuple-slots ( -- )
- scan parse-slot-name [ parse-tuple-slots ] when ;
+ ";" 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 ]
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 ;
-: boa>tuple ( class slots -- tuple )
- swap prefix >tuple ;
+GENERIC#: boa>object 1 ( class slots -- tuple )
+
+M: tuple-class boa>object
+ 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>tuple ( class slots -- tuple )
- [ [ ] [ initial-values ] [ all-slots ] tri ] dip
- swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
- [ dup <enum> ] dip update boa>tuple ;
+: 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 -- tuple )
- scan {
- { f [ unexpected-eof ] }
- { "f" [ \ } parse-until boa>tuple ] }
- { "{" [ parse-slot-values assoc>tuple ] }
- { "}" [ new ] }
+: 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 ;