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