basis/macros/macros.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: parser kernel sequences words effects combinators assocs
   4 definitions quotations namespaces memoize accessors arrays
   5 compiler.units ;
   6 IN: macros
   7
   8 <PRIVATE
   9
  10 ! The macro expander is split off into its own word. This allows
  11 ! the optimizing compiler to optimize and check the stack effect
  12 ! of the expander, even though the actual macro word does not
  13 ! infer.
  14
  15 : real-macro-effect ( effect -- effect' )
  16     in>> { "quot" } <effect> ;
  17
  18 PREDICATE: macro-body < memoized "macro-owner" word-prop >boolean ;
  19
  20 : <macro-body> ( word quot effect -- macro-body )
  21     real-macro-effect
  22     [ name>> "( macro body: " " )" surround <uninterned-word> dup ] 2dip
  23     define-memoized ;
  24
  25 M: macro-body crossref? "forgotten" word-prop not ;
  26
  27 M: macro-body reset-word
  28     [ call-next-method ] [ "macro-body" remove-word-prop ] bi ;
  29
  30 M: macro-body where "macro-owner" word-prop where ;
  31
  32 : reset-macro ( word -- )
  33     [ "macro" word-prop forget ] [ f "macro" set-word-prop ] bi ;
  34
  35 PRIVATE>
  36
  37 : define-macro ( word quot effect -- )
  38     [ 2drop ] [ <macro-body> ] 3bi
  39     {
  40         [ "macro" set-word-prop ]
  41         [ swap "macro-owner" set-word-prop ]
  42         [ [ \ call [ ] 2sequence ] [ stack-effect ] bi define-declared ]
  43         [ drop changed-effect ]
  44     } 2cleave ;
  45
  46 SYNTAX: MACRO: (:) define-macro ;
  47
  48 PREDICATE: macro < word "macro" word-prop >boolean ;
  49
  50 M: macro make-inline cannot-be-inline ;
  51
  52 M: macro definer drop \ MACRO: \ ; ;
  53
  54 M: macro definition "macro" word-prop definition ;
  55
  56 M: macro subwords "macro" word-prop 1array ;
  57
  58 M: macro reset-word [ call-next-method ] [ reset-macro ] bi ;
  59
  60 M: macro forget* [ call-next-method ] [ reset-macro ] bi ;
  61
  62 M: macro always-bump-effect-counter? drop t ;