basis/macros/expander/expander.factor

   1 ! Copyright (C) 2008, 2009 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 ;
   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-macro ( 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-macro? ( word -- quot ? )
  69     dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
  70         swap [ "transform-n" word-prop ] [ stack-effect in>> length ] bi or
  71         stack get length <=
  72     ] [ 2drop f f ] if ;
  73
  74 M: word expand-macros*
  75     dup expand-dispatch? [ drop expand-dispatch ] [
  76         dup expand-macro? [ expand-macro ] [
  77             drop word,
  78         ] if
  79     ] if ;
  80
  81 M: object expand-macros* literal ;
  82
  83 M: callable expand-macros*
  84     expand-macros literal ;
  85
  86 M: callable expand-macros ( quot -- quot' )
  87     [ begin (expand-macros) end ] [ ] make ;