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