basis/macros/expander/expander.factor

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