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 ;
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 ( 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 { [ dup ";" = ] [ drop f ] }
47 [ dup "{" = [ drop parse-long-slot-name ] when , t ]
50 : parse-tuple-slots ( -- )
51 scan parse-slot-name [ parse-tuple-slots ] when ;
53 : parse-tuple-definition ( -- class superclass slots )
57 { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
58 [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
60 dup check-duplicate-slots
61 3dup check-slot-shadowing ;
63 ERROR: bad-literal-tuple ;
65 : parse-slot-value ( -- )
66 scan scan-object 2array , scan {
67 { f [ \ } unexpected-eof ] }
72 : (parse-slot-values) ( -- )
75 { f [ \ } unexpected-eof ] }
76 { "{" [ (parse-slot-values) ] }
81 : parse-slot-values ( -- values )
82 [ (parse-slot-values) ] { } make ;
84 : boa>tuple ( class slots -- tuple )
87 : assoc>tuple ( class slots -- tuple )
88 [ [ ] [ initial-values ] [ all-slots ] tri ] dip
89 swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
90 [ dup <enum> ] dip update boa>tuple ;
92 : parse-tuple-literal-slots ( class -- tuple )
94 { f [ unexpected-eof ] }
95 { "f" [ \ } parse-until boa>tuple ] }
96 { "{" [ parse-slot-values assoc>tuple ] }
101 : parse-tuple-literal ( -- tuple )
102 scan-word parse-tuple-literal-slots ;