basis/tools/annotations/annotations.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel words parser io summary quotations
   4 sequences prettyprint continuations effects definitions
   5 compiler.units namespaces assocs tools.walker generic
   6 inspector ;
   7 IN: tools.annotations
   8
   9 GENERIC: reset ( word -- )
  10
  11 M: generic reset
  12     [ call-next-method ]
  13     [ subwords [ reset ] each ] bi ;
  14
  15 M: word reset
  16     dup "unannotated-def" word-prop [
  17         [
  18             dup dup "unannotated-def" word-prop define
  19         ] with-compilation-unit
  20         f "unannotated-def" set-word-prop
  21     ] [ drop ] if ;
  22
  23 : annotate ( word quot -- )
  24     over "unannotated-def" word-prop [
  25         "Cannot annotate a word twice" throw
  26     ] when
  27     [
  28         over dup def>> "unannotated-def" set-word-prop
  29         >r dup def>> r> call define
  30     ] with-compilation-unit ; inline
  31
  32 : word-inputs ( word -- seq )
  33     stack-effect [
  34         >r datastack r> effect-in length tail*
  35     ] [
  36         datastack
  37     ] if* ;
  38
  39 : entering ( str -- )
  40     "/-- Entering: " write dup .
  41     word-inputs stack.
  42     "\\--" print flush ;
  43
  44 : leaving ( str -- )
  45     "/-- Leaving: " write dup .
  46     stack-effect [
  47         >r datastack r> effect-out length tail* stack.
  48     ] [
  49         .s
  50     ] if* "\\--" print flush ;
  51
  52 : (watch) ( word def -- def )
  53     over [ entering ] curry
  54     rot [ leaving ] curry
  55     swapd 3append ;
  56
  57 : watch ( word -- )
  58     dup [ (watch) ] annotate ;
  59
  60 : (watch-vars) ( quot word vars -- newquot )
  61     [
  62         "--- Entering: " write swap .
  63         "--- Variable values:" print
  64         [ dup get ] H{ } map>assoc describe
  65     ] 2curry prepose ;
  66
  67 : watch-vars ( word vars -- )
  68     dupd [ (watch-vars) ] 2curry annotate ;
  69
  70 GENERIC# annotate-methods 1 ( word quot -- )
  71
  72 M: generic annotate-methods
  73     >r "methods" word-prop values r> [ annotate ] curry each ;
  74
  75 M: word annotate-methods
  76     annotate ;
  77
  78 : breakpoint ( word -- )
  79     [ add-breakpoint ] annotate-methods ;
  80
  81 : breakpoint-if ( word quot -- )
  82     [ [ [ break ] when ] rot 3append ] curry annotate-methods ;