1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes.mixin classes.parser classes.singleton
4 classes.tuple classes.tuple.parser combinators effects effects.parser
5 fry generic generic.parser generic.standard interpolate
6 io.streams.string kernel lexer locals.parser locals.rewrite.closures
7 locals.types make namespaces parser quotations sequences vocabs.parser
15 : scan-param ( -- obj ) scan-object literalize ;
17 : define* ( word def -- ) over set-word define ;
19 : define-declared* ( word def effect -- ) pick set-word define-declared ;
21 : define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
23 TUPLE: fake-call-next-method ;
25 TUPLE: fake-quotation seq ;
27 GENERIC: >fake-quotations ( quot -- fake )
29 M: callable >fake-quotations
30 >array >fake-quotations fake-quotation boa ;
32 M: array >fake-quotations [ >fake-quotations ] { } map-as ;
34 M: object >fake-quotations ;
36 GENERIC: (fake-quotations>) ( fake -- )
38 : fake-quotations> ( fake -- quot )
39 [ (fake-quotations>) ] [ ] make ;
41 M: fake-quotation (fake-quotations>)
42 [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
44 M: array (fake-quotations>)
45 [ [ (fake-quotations>) ] each ] { } make , ;
47 M: fake-call-next-method (fake-quotations>)
48 drop method-body get literalize , \ (call-next-method) , ;
50 M: object (fake-quotations>) , ;
52 : parse-definition* ( accum -- accum )
53 parse-definition >fake-quotations parsed
54 [ fake-quotations> first ] over push-all ;
56 : parse-declared* ( accum -- accum )
58 [ parse-definition* ] dip
64 { ";" [ tuple parsed f parsed ] }
65 { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
68 [ parse-slot-name [ parse-tuple-slots ] when ] { }
72 \ define-tuple-class parsed ;
76 \ define-singleton-class parsed ;
80 \ define-mixin-class parsed ;
85 [ create-method-in dup method-body set ] over push-all
93 [ [ [ boa ] curry ] over push-all ] dip parsed
94 \ define-declared* parsed ;
99 \ define-declared* parsed ;
103 \ define-symbol parsed ;
108 \ define-syntax parsed ;
113 \ add-mixin-instance parsed ;
117 complete-effect parsed
118 \ define-simple-generic* parsed ;
120 SYNTAX: `inline [ word make-inline ] over push-all ;
122 SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
124 : (INTERPOLATE) ( accum quot -- accum )
125 [ scan interpolate-locals ] dip
126 '[ _ with-string-writer @ ] parsed ;
130 SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
132 SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
134 SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
136 SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
138 DEFER: ;FUNCTOR delimiter
142 : functor-words ( -- assoc )
144 { "TUPLE:" POSTPONE: `TUPLE: }
145 { "SINGLETON:" POSTPONE: `SINGLETON: }
146 { "MIXIN:" POSTPONE: `MIXIN: }
147 { "M:" POSTPONE: `M: }
148 { "C:" POSTPONE: `C: }
150 { "GENERIC:" POSTPONE: `GENERIC: }
151 { "INSTANCE:" POSTPONE: `INSTANCE: }
152 { "SYNTAX:" POSTPONE: `SYNTAX: }
153 { "SYMBOL:" POSTPONE: `SYMBOL: }
154 { "inline" POSTPONE: `inline }
155 { "call-next-method" POSTPONE: `call-next-method }
158 : push-functor-words ( -- )
159 functor-words use-words ;
161 : pop-functor-words ( -- )
162 functor-words unuse-words ;
164 : parse-functor-body ( -- form )
166 "WHERE" parse-bindings*
167 [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
170 : (FUNCTOR:) ( -- word def effect )
171 CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
175 SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;