basis/macros/expander/expander.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences sequences.private namespaces make
   4 quotations accessors words continuations vectors effects math
   5 generalizations fry arrays combinators ;
   6 IN: macros.expander
   7
   8 GENERIC: expand-macros ( quot -- quot' )
   9
  10 SYMBOL: stack
  11
  12 : begin ( -- ) V{ } clone stack set ;
  13
  14 : end ( -- )
  15     stack get
  16     [ [ literalize , ] each ]
  17     [ delete-all ]
  18     bi ;
  19
  20 GENERIC: condomize? ( obj -- ? )
  21
  22 M: array condomize? [ condomize? ] any? ;
  23
  24 M: callable condomize? [ condomize? ] any? ;
  25
  26 M: object condomize? drop f ;
  27
  28 GENERIC: condomize ( obj -- obj' )
  29
  30 M: array condomize [ condomize ] map ;
  31
  32 M: callable condomize [ condomize ] map ;
  33
  34 M: object condomize ;
  35
  36 : literal ( obj -- ) dup condomize? [ condomize ] when stack get push ;
  37
  38 GENERIC: expand-macros* ( obj -- )
  39
  40 : (expand-macros) ( quot -- )
  41     [ expand-macros* ] each ;
  42
  43 M: wrapper expand-macros* wrapped>> literal ;
  44
  45 : expand-dispatch? ( word -- ? )
  46     \ dispatch eq? stack get length 1 >= and ;
  47
  48 : expand-dispatch ( -- )
  49     stack get pop end
  50     [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
  51     [
  52         length iota [ <reversed> ] keep
  53         [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
  54     ] bi ;
  55
  56 : word, ( word -- ) end , ;
  57
  58 : expand-transform ( word quot -- )
  59     '[
  60         drop
  61         stack [ _ with-datastack >vector ] change
  62         stack get pop >quotation end (expand-macros)
  63     ] [
  64         drop
  65         word,
  66     ] recover ;
  67
  68 : expand-transform? ( word -- ? )
  69     dup "transform-quot" word-prop [
  70         "transform-n" word-prop
  71         stack get length <=
  72     ] [ drop f ] if ;
  73
  74 : expand-macro? ( word -- ? )
  75     dup "macro" word-prop [
  76         stack-effect in>> length
  77         stack get length <=
  78     ] [ drop f ] if ;
  79
  80 M: word expand-macros*
  81     {
  82         { [ dup expand-dispatch? ] [ drop expand-dispatch ] }
  83         { [ dup expand-macro? ] [ dup "macro" word-prop '[ _ execute ] expand-transform ] }
  84         { [ dup expand-transform? ] [ dup "transform-quot" word-prop expand-transform ] }
  85         [ word, ]
  86     } cond ;
  87
  88 M: object expand-macros* literal ;
  89
  90 M: callable expand-macros*
  91     expand-macros literal ;
  92
  93 M: callable expand-macros ( quot -- quot' )
  94     [ begin (expand-macros) end ] [ ] make ;