basis/functors/functors.factor

   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 ;
   9 IN: functors
  10
  11 ! This is a hack
  12
  13 <PRIVATE
  14
  15 TUPLE: fake-call-next-method ;
  16
  17 TUPLE: fake-quotation seq ;
  18
  19 GENERIC: >fake-quotations ( quot -- fake )
  20
  21 M: callable >fake-quotations
  22     >array >fake-quotations fake-quotation boa ;
  23
  24 M: array >fake-quotations [ >fake-quotations ] { } map-as ;
  25
  26 M: object >fake-quotations ;
  27
  28 GENERIC: (fake-quotations>) ( fake -- )
  29
  30 : fake-quotations> ( fake -- quot )
  31     [ (fake-quotations>) ] [ ] make ;
  32
  33 M: fake-quotation (fake-quotations>)
  34     [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
  35
  36 M: array (fake-quotations>)
  37     [ [ (fake-quotations>) ] each ] { } make , ;
  38
  39 M: fake-call-next-method (fake-quotations>)
  40     drop \ method get literalize , \ (call-next-method) , ;
  41
  42 M: object (fake-quotations>) , ;
  43
  44 : parse-definition* ( accum -- accum )
  45     parse-definition >fake-quotations suffix!
  46     [ fake-quotations> first ] append! ;
  47
  48 : parse-declared* ( accum -- accum )
  49     scan-effect
  50     [ parse-definition* ] dip
  51     suffix! ;
  52
  53 FUNCTOR-SYNTAX: TUPLE:
  54     scan-param suffix!
  55     scan-token {
  56         { ";" [ tuple suffix! f suffix! ] }
  57         { "<" [ scan-param suffix! [ parse-tuple-slots ] { } make suffix! ] }
  58         [
  59             [ tuple suffix! ] dip
  60             [ parse-slot-name [ parse-tuple-slots ] when ] { }
  61             make suffix!
  62         ]
  63     } case
  64     \ define-tuple-class* suffix! ;
  65
  66 FUNCTOR-SYNTAX: final
  67     [ word make-final ] append! ;
  68
  69 FUNCTOR-SYNTAX: SINGLETON:
  70     scan-param suffix!
  71     \ define-singleton-class suffix! ;
  72
  73 FUNCTOR-SYNTAX: MIXIN:
  74     scan-param suffix!
  75     \ define-mixin-class suffix! ;
  76
  77 FUNCTOR-SYNTAX: M:
  78     scan-param suffix!
  79     scan-param suffix!
  80     [ create-method-in dup \ method set ] append!
  81     parse-definition*
  82     \ define* suffix! ;
  83
  84 FUNCTOR-SYNTAX: C:
  85     scan-param suffix!
  86     scan-param suffix!
  87     scan-effect
  88     [ [ [ boa ] curry ] append! ] dip suffix!
  89     \ define-declared* suffix! ;
  90
  91 FUNCTOR-SYNTAX: :
  92     scan-param suffix!
  93     parse-declared*
  94     \ define-declared* suffix! ;
  95
  96 FUNCTOR-SYNTAX: SYMBOL:
  97     scan-param suffix!
  98     \ define-symbol suffix! ;
  99
 100 FUNCTOR-SYNTAX: SYNTAX:
 101     scan-param suffix!
 102     parse-definition*
 103     \ define-syntax suffix! ;
 104
 105 FUNCTOR-SYNTAX: INSTANCE:
 106     scan-param suffix!
 107     scan-param suffix!
 108     \ add-mixin-instance suffix! ;
 109
 110 FUNCTOR-SYNTAX: GENERIC:
 111     scan-param suffix!
 112     scan-effect suffix!
 113     \ define-simple-generic* suffix! ;
 114
 115 FUNCTOR-SYNTAX: MACRO:
 116     scan-param suffix!
 117     parse-declared*
 118     \ define-macro suffix! ;
 119
 120 FUNCTOR-SYNTAX: inline [ word make-inline ] append! ;
 121
 122 FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ;
 123
 124 : (INTERPOLATE) ( accum quot -- accum )
 125     [ scan-token interpolate-locals ] dip
 126     '[ _ with-string-writer @ ] suffix! ;
 127
 128 PRIVATE>
 129
 130 SYNTAX: IS [ parse-word ] (INTERPOLATE) ;
 131
 132 SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
 133
 134 SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
 135
 136 SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ;
 137
 138 SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
 139
 140 DEFER: ;FUNCTOR delimiter
 141
 142 <PRIVATE
 143
 144 : push-functor-words ( -- )
 145     functor-words use-words ;
 146
 147 : pop-functor-words ( -- )
 148     functor-words unuse-words ;
 149
 150 : (parse-bindings) ( end -- words )
 151     [ dup parse-binding dup ]
 152     [ first2 [ make-local ] dip 2array ]
 153     produce 2nip ;
 154
 155 : with-bindings ( quot -- words assoc )
 156     in-lambda? on H{ } make ; inline
 157
 158 : parse-bindings ( end -- words assoc )
 159     [
 160         building get use-words
 161         (parse-bindings)
 162         building get unuse-words
 163     ] with-bindings ;
 164
 165 : parse-functor-body ( -- form )
 166     push-functor-words
 167     "WHERE" parse-bindings
 168     [ [ swap <def> suffix ] { } assoc>map concat ]
 169     [ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
 170     [ ] append-as
 171     pop-functor-words ;
 172
 173 : (FUNCTOR:) ( -- word def effect )
 174     scan-new-word [ parse-functor-body ] parse-locals-definition ;
 175
 176 PRIVATE>
 177
 178 SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;