basis/functors/functors.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel quotations classes.tuple make combinators generic
   4 words interpolate namespaces sequences io.streams.string fry
   5 classes.mixin effects lexer parser classes.tuple.parser
   6 effects.parser locals.types locals.parser
   7 locals.rewrite.closures vocabs.parser arrays accessors ;
   8 IN: functors
   9
  10 ! This is a hack
  11
  12 <PRIVATE
  13
  14 : scan-param ( -- obj ) scan-object literalize ;
  15
  16 : define* ( word def effect -- ) pick set-word define-declared ;
  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 -- quot )
  30
  31 M: fake-quotation fake-quotations>
  32     seq>> [ fake-quotations> ] map >quotation ;
  33
  34 M: array fake-quotations> [ fake-quotations> ] map ;
  35
  36 M: object fake-quotations> ;
  37
  38 : parse-definition* ( -- )
  39     parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
  40
  41 : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
  42
  43 : `TUPLE:
  44     scan-param parsed
  45     scan {
  46         { ";" [ tuple parsed f parsed ] }
  47         { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
  48         [
  49             [ tuple parsed ] dip
  50             [ parse-slot-name [ parse-tuple-slots ] when ] { }
  51             make parsed
  52         ]
  53     } case
  54     \ define-tuple-class parsed ; parsing
  55
  56 : `M:
  57     effect off
  58     scan-param parsed
  59     scan-param parsed
  60     \ create-method parsed
  61     parse-definition*
  62     DEFINE* ; parsing
  63
  64 : `C:
  65     effect off
  66     scan-param parsed
  67     scan-param parsed
  68     [ [ boa ] curry ] over push-all
  69     DEFINE* ; parsing
  70
  71 : `:
  72     effect off
  73     scan-param parsed
  74     parse-definition*
  75     DEFINE* ; parsing
  76
  77 : `INSTANCE:
  78     scan-param parsed
  79     scan-param parsed
  80     \ add-mixin-instance parsed ; parsing
  81
  82 : `inline \ inline parsed ; parsing
  83
  84 : `parsing \ parsing parsed ; parsing
  85
  86 : `(
  87     ")" parse-effect effect set ; parsing
  88
  89 : (INTERPOLATE) ( accum quot -- accum )
  90     [ scan interpolate-locals ] dip
  91     '[ _ with-string-writer @ ] parsed ;
  92
  93 PRIVATE>
  94
  95 : IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
  96
  97 : DEFINES [ create-in ] (INTERPOLATE) ; parsing
  98
  99 DEFER: ;FUNCTOR delimiter
 100
 101 <PRIVATE
 102
 103 : functor-words ( -- assoc )
 104     H{
 105         { "TUPLE:" POSTPONE: `TUPLE: }
 106         { "M:" POSTPONE: `M: }
 107         { "C:" POSTPONE: `C: }
 108         { ":" POSTPONE: `: }
 109         { "INSTANCE:" POSTPONE: `INSTANCE: }
 110         { "inline" POSTPONE: `inline }
 111         { "parsing" POSTPONE: `parsing }
 112         { "(" POSTPONE: `( }
 113     } ;
 114
 115 : push-functor-words ( -- )
 116     functor-words use get push ;
 117
 118 : pop-functor-words ( -- )
 119     functor-words use get delq ;
 120
 121 : parse-functor-body ( -- form )
 122     t in-lambda? [
 123         V{ } clone
 124         push-functor-words
 125         "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
 126         <let*> parsed-lambda
 127         pop-functor-words
 128         >quotation
 129     ] with-variable ;
 130
 131 : (FUNCTOR:) ( -- word def )
 132     CREATE
 133     parse-locals dup push-locals
 134     parse-functor-body swap pop-locals <lambda>
 135     rewrite-closures first ;
 136
 137 PRIVATE>
 138
 139 : FUNCTOR: (FUNCTOR:) define ; parsing