1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel new-sets namespaces make sequences parser
4 lexer combinators words classes.parser classes.tuple arrays
5 slots math assocs parser.notes classes classes.algebra ;
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 , \ } parse-until % ] { } make ;
36 : parse-slot-name-delim ( end-delim string/f -- ? )
37 #! This isn't meant to enforce any kind of policy, just
38 #! to check for mistakes of this form:
40 #! TUPLE: blahblah foo bing
44 { [ dup not ] [ unexpected-eof ] }
45 { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
46 { [ 2dup = ] [ drop f ] }
47 [ dup "{" = [ drop parse-long-slot-name ] when , t ]
50 : parse-tuple-slots-delim ( end-delim -- )
51 dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
53 : parse-slot-name ( string/f -- ? )
54 ";" swap parse-slot-name-delim ;
56 : parse-tuple-slots ( -- )
57 ";" parse-tuple-slots-delim ;
59 : parse-tuple-definition ( -- class superclass slots )
63 { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
64 [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
66 dup check-duplicate-slots
67 3dup check-slot-shadowing ;
69 ERROR: bad-literal-tuple ;
71 : parse-slot-value ( -- )
72 scan scan-object 2array , scan {
73 { f [ \ } unexpected-eof ] }
78 : (parse-slot-values) ( -- )
81 { f [ \ } unexpected-eof ] }
82 { "{" [ (parse-slot-values) ] }
87 : parse-slot-values ( -- values )
88 [ (parse-slot-values) ] { } make ;
90 GENERIC# boa>object 1 ( class slots -- tuple )
92 M: tuple-class boa>object
95 ERROR: bad-slot-name class slot ;
97 : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
98 over [ drop ] [ nip nip nip bad-slot-name ] if ;
100 : slot-named-checked ( class initials name slots -- class initials slot-spec )
101 over [ slot-named* ] dip check-slot-exists drop ;
103 : assoc>object ( class slots values -- tuple )
104 [ [ [ initial>> ] map <enum> ] keep ] dip
105 swap [ [ slot-named-checked ] curry dip ] curry assoc-map
106 assoc-union! seq>> boa>object ;
108 : parse-tuple-literal-slots ( class slots -- tuple )
110 { f [ unexpected-eof ] }
111 { "f" [ drop \ } parse-until boa>object ] }
112 { "{" [ parse-slot-values assoc>object ] }
114 [ bad-literal-tuple ]
117 : parse-tuple-literal ( -- tuple )
118 scan-word dup all-slots parse-tuple-literal-slots ;