basis/functors/functors.factor

   1 ! Copyright (C) 2008 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 ;
   8 IN: functors
   9
  10 : scan-param ( -- obj )
  11     scan-object dup special? [ literalize ] unless ;
  12
  13 : define* ( word def effect -- ) pick set-word define-declared ;
  14
  15 : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
  16
  17 : `TUPLE:
  18     scan-param parsed
  19     scan {
  20         { ";" [ tuple parsed f parsed ] }
  21         { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
  22         [
  23             [ tuple parsed ] dip
  24             [ parse-slot-name [ parse-tuple-slots ] when ] { }
  25             make parsed
  26         ]
  27     } case
  28     \ define-tuple-class parsed ; parsing
  29
  30 : `M:
  31     effect off
  32     scan-param parsed
  33     scan-param parsed
  34     \ create-method parsed
  35     parse-definition parsed
  36     DEFINE* ; parsing
  37
  38 : `C:
  39     effect off
  40     scan-param parsed
  41     scan-param parsed
  42     [ [ boa ] curry ] over push-all
  43     DEFINE* ; parsing
  44
  45 : `:
  46     effect off
  47     scan-param parsed
  48     parse-definition parsed
  49     DEFINE* ; parsing
  50
  51 : `INSTANCE:
  52     scan-param parsed
  53     scan-param parsed
  54     \ add-mixin-instance parsed ; parsing
  55
  56 : `inline \ inline parsed ; parsing
  57
  58 : `parsing \ parsing parsed ; parsing
  59
  60 : `(
  61     ")" parse-effect effect set ; parsing
  62
  63 : (INTERPOLATE) ( accum quot -- accum )
  64     [ scan interpolate-locals ] dip
  65     '[ _ with-string-writer @ ] parsed ;
  66
  67 : IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
  68
  69 : DEFINES [ create-in ] (INTERPOLATE) ; parsing
  70
  71 DEFER: ;FUNCTOR delimiter
  72
  73 : functor-words ( -- assoc )
  74     H{
  75         { "TUPLE:" POSTPONE: `TUPLE: }
  76         { "M:" POSTPONE: `M: }
  77         { "C:" POSTPONE: `C: }
  78         { ":" POSTPONE: `: }
  79         { "INSTANCE:" POSTPONE: `INSTANCE: }
  80         { "inline" POSTPONE: `inline }
  81         { "parsing" POSTPONE: `parsing }
  82         { "(" POSTPONE: `( }
  83     } ;
  84
  85 : push-functor-words ( -- )
  86     functor-words use get push ;
  87
  88 : pop-functor-words ( -- )
  89     functor-words use get delq ;
  90
  91 : parse-functor-body ( -- form )
  92     t in-lambda? [
  93         V{ } clone
  94         push-functor-words
  95         "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
  96         <let*> parsed-lambda
  97         pop-functor-words
  98         >quotation
  99     ] with-variable ;
 100
 101 : (FUNCTOR:) ( -- word def )
 102     CREATE
 103     parse-locals dup push-locals
 104     parse-functor-body swap pop-locals <lambda>
 105     rewrite-closures first ;
 106
 107 : FUNCTOR: (FUNCTOR:) define ; parsing