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