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