basis/macros/expander/expander.factor

   1 ! Copyright (C) 2008 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 ;
   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 : literal ( obj -- ) stack get push ;
  21
  22 GENERIC: expand-macros* ( obj -- )
  23
  24 : (expand-macros) ( quot -- )
  25     [ expand-macros* ] each ;
  26
  27 M: wrapper expand-macros* wrapped>> literal ;
  28
  29 : expand-dispatch? ( word -- ? )
  30     \ dispatch eq? stack get length 1 >= and ;
  31
  32 : expand-dispatch ( -- )
  33     stack get pop end
  34     [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
  35     [
  36         length [ <reversed> ] keep
  37         [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
  38     ] bi ;
  39
  40 : word, ( word -- ) end , ;
  41
  42 : expand-macro ( word quot -- )
  43     '[
  44         drop
  45         stack [ _ with-datastack >vector ] change
  46         stack get pop >quotation end (expand-macros)
  47     ] [
  48         drop
  49         word,
  50     ] recover ;
  51
  52 : expand-macro? ( word -- quot ? )
  53     dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
  54         swap [ "transform-n" word-prop ] [ stack-effect in>> length ] bi or
  55         stack get length <=
  56     ] [ 2drop f f ] if ;
  57
  58 M: word expand-macros*
  59     dup expand-dispatch? [ drop expand-dispatch ] [
  60         dup expand-macro? [ expand-macro ] [
  61             drop word,
  62         ] if
  63     ] if ;
  64
  65 M: object expand-macros* literal ;
  66
  67 M: callable expand-macros*
  68     expand-macros literal ;
  69
  70 M: callable expand-macros ( quot -- quot' )
  71     [ begin (expand-macros) end ] [ ] make ;