core/macros/expander/expander.factor

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