1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes.parser classes.tuple
4 combinators kernel lexer make parser parser.notes sequences
6 IN: classes.tuple.parser
8 : slot-names ( slots -- seq )
9 [ dup array? [ first ] when ] map ;
11 : shadowed-slots ( superclass slots -- shadowed )
12 [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
14 : check-slot-shadowing ( class superclass slots -- )
17 "Definition of slot ``" %
21 "'' shadows a superclass slot" %
25 ERROR: duplicate-slot-names names ;
27 : check-duplicate-slots ( slots -- )
29 [ duplicate-slot-names ] unless-empty ;
31 ERROR: invalid-slot-name name ;
33 : parse-long-slot-name ( -- spec )
34 [ scan-token , \ } parse-until % ] { } make ;
36 : parse-slot-name-delim ( end-delim string/f -- ? )
37 ! Check for mistakes of this form:
39 ! TUPLE: blahblah foo bing
43 { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
44 { [ 2dup = ] [ drop f ] }
45 [ dup "{" = [ drop parse-long-slot-name ] when , t ]
48 : parse-tuple-slots-delim ( end-delim -- )
49 dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
51 : parse-slot-name ( string/f -- ? )
52 ";" swap parse-slot-name-delim ;
54 : parse-tuple-slots ( -- )
55 ";" parse-tuple-slots-delim ;
57 : parse-tuple-definition ( -- class superclass slots )
61 { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
62 [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
64 dup check-duplicate-slots
65 3dup check-slot-shadowing ;
67 ERROR: bad-literal-tuple ;
69 ERROR: bad-slot-name class slot ;
71 : check-slot-name ( class slots name -- name )
72 2dup swap slot-named [ 2nip ] [ nip bad-slot-name ] if ;
74 : parse-slot-value ( class slots -- )
75 scan-token check-slot-name scan-object 2array , scan-token {
80 : (parse-slot-values) ( class slots -- )
83 { "{" [ (parse-slot-values) ] }
85 [ 2nip bad-literal-tuple ]
88 : parse-slot-values ( class slots -- values )
89 [ (parse-slot-values) ] { } make ;
91 GENERIC# boa>object 1 ( class slots -- tuple )
93 M: tuple-class boa>object
96 : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
97 over [ drop ] [ nip nip nip bad-slot-name ] if ;
99 : slot-named-checked ( class initials name slots -- class initials slot-spec )
100 over [ slot-named* ] dip check-slot-exists drop ;
102 : assoc>object ( class slots values -- tuple )
103 [ [ [ initial>> ] map <enum> ] keep ] dip
104 swap [ [ slot-named-checked ] curry dip ] curry assoc-map
105 assoc-union! seq>> boa>object ;
107 : parse-tuple-literal-slots ( class slots -- tuple )
109 { "f" [ drop \ } parse-until boa>object ] }
110 { "{" [ 2dup parse-slot-values assoc>object ] }
112 [ bad-literal-tuple ]
115 : parse-tuple-literal ( -- tuple )
116 scan-word dup all-slots parse-tuple-literal-slots ;