1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes.mixin classes.parser
4 classes.singleton classes.tuple classes.tuple.parser
5 combinators effects.parser fry functors.backend generic
6 generic.parser interpolate io.streams.string kernel lexer
7 locals.parser locals.types macros make namespaces parser
8 quotations sequences vocabs.parser words words.symbol ;
15 TUPLE: fake-call-next-method ;
17 TUPLE: fake-quotation seq ;
19 GENERIC: >fake-quotations ( quot -- fake )
21 M: callable >fake-quotations
22 >array >fake-quotations fake-quotation boa ;
24 M: array >fake-quotations [ >fake-quotations ] { } map-as ;
26 M: object >fake-quotations ;
28 GENERIC: (fake-quotations>) ( fake -- )
30 : fake-quotations> ( fake -- quot )
31 [ (fake-quotations>) ] [ ] make ;
33 M: fake-quotation (fake-quotations>)
34 [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
36 M: array (fake-quotations>)
37 [ [ (fake-quotations>) ] each ] { } make , ;
39 M: fake-call-next-method (fake-quotations>)
40 drop \ method get literalize , \ (call-next-method) , ;
42 M: object (fake-quotations>) , ;
44 : parse-definition* ( accum -- accum )
45 parse-definition >fake-quotations suffix!
46 [ fake-quotations> first ] append! ;
48 : parse-declared* ( accum -- accum )
50 [ parse-definition* ] dip
53 FUNCTOR-SYNTAX: TUPLE:
56 { ";" [ tuple suffix! f suffix! ] }
57 { "<" [ scan-param suffix! [ parse-tuple-slots ] { } make suffix! ] }
60 [ parse-slot-name [ parse-tuple-slots ] when ] { }
64 \ define-tuple-class* suffix! ;
67 [ last-word make-final ] append! ;
69 FUNCTOR-SYNTAX: SINGLETON:
71 \ define-singleton-class suffix! ;
73 FUNCTOR-SYNTAX: MIXIN:
75 \ define-mixin-class suffix! ;
80 [ create-method-in dup \ method set ] append!
88 [ [ [ boa ] curry ] append! ] dip suffix!
89 \ define-declared* suffix! ;
94 \ define-declared* suffix! ;
96 FUNCTOR-SYNTAX: SYMBOL:
98 \ define-symbol suffix! ;
100 FUNCTOR-SYNTAX: SYNTAX:
103 \ define-syntax suffix! ;
105 FUNCTOR-SYNTAX: INSTANCE:
108 \ add-mixin-instance suffix! ;
110 FUNCTOR-SYNTAX: GENERIC:
113 \ define-simple-generic* suffix! ;
115 FUNCTOR-SYNTAX: MACRO:
118 \ define-macro suffix! ;
120 FUNCTOR-SYNTAX: inline [ last-word make-inline ] append! ;
122 FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ;
124 : (INTERPOLATE) ( accum quot -- accum )
125 [ scan-token interpolate-locals ] dip
126 '[ _ with-string-writer @ ] suffix! ;
130 SYNTAX: IS [ parse-word ] (INTERPOLATE) ;
132 SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
134 SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
136 SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ;
138 SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
140 DEFER: ;FUNCTOR delimiter
144 : push-functor-words ( -- )
145 functor-words use-words ;
147 : pop-functor-words ( -- )
148 functor-words unuse-words ;
150 : (parse-bindings) ( end -- words )
151 [ dup parse-binding dup ]
152 [ first2 [ make-local ] dip 2array ]
155 : with-bindings ( quot -- words assoc )
156 in-lambda? on H{ } make ; inline
158 : parse-bindings ( end -- words assoc )
160 building get use-words
162 building get unuse-words
165 : parse-functor-body ( -- form )
167 "WHERE" parse-bindings
168 [ [ swap <def> suffix ] { } assoc>map concat ]
169 [ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
173 : (FUNCTOR:) ( -- word def effect )
174 scan-new-word [ parse-functor-body ] parse-locals-definition ;
178 SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;