1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel sets namespaces make sequences parser
4 lexer combinators words classes.parser classes.tuple arrays
5 slots math assocs parser.notes 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 ERROR: bad-inheritance class superclass ;
61 : check-inheritance ( class1 class2 -- class1 class2 )
62 2dup swap class<= [ bad-inheritance ] when ;
64 : parse-tuple-definition ( -- class superclass slots )
66 scan 2dup = [ ] when {
69 scan-word check-inheritance [ parse-tuple-slots ] { } make
71 [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
73 dup check-duplicate-slots
74 3dup check-slot-shadowing ;
76 ERROR: bad-literal-tuple ;
78 : parse-slot-value ( -- )
79 scan scan-object 2array , scan {
80 { f [ \ } unexpected-eof ] }
85 : (parse-slot-values) ( -- )
88 { f [ \ } unexpected-eof ] }
89 { "{" [ (parse-slot-values) ] }
94 : parse-slot-values ( -- values )
95 [ (parse-slot-values) ] { } make ;
97 GENERIC# boa>object 1 ( class slots -- tuple )
99 M: tuple-class boa>object
102 ERROR: bad-slot-name class slot ;
104 : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
105 over [ drop ] [ nip nip nip bad-slot-name ] if ;
107 : slot-named-checked ( class initials name slots -- class initials slot-spec )
108 over [ slot-named* ] dip check-slot-exists drop ;
110 : assoc>object ( class slots values -- tuple )
111 [ [ [ initial>> ] map ] keep ] dip
112 swap [ [ slot-named-checked ] curry dip ] curry assoc-map
113 [ dup <enum> ] dip update boa>object ;
115 : parse-tuple-literal-slots ( class slots -- tuple )
117 { f [ unexpected-eof ] }
118 { "f" [ drop \ } parse-until boa>object ] }
119 { "{" [ parse-slot-values assoc>object ] }
121 [ bad-literal-tuple ]
124 : parse-tuple-literal ( -- tuple )
125 scan-word dup all-slots parse-tuple-literal-slots ;