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 fry ;
   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> 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> out>> length tail* stack.
  48     ] [
  49         .s
  50     ] if* "\\--" print flush ;
  51
  52 : (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ;
  53
  54 : watch ( word -- )
  55     dup [ (watch) ] annotate ;
  56
  57 : (watch-vars) ( quot word vars -- newquot )
  58     rot
  59    '[
  60         "--- Entering: "       write _ .
  61         "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
  62         @
  63     ] ;
  64
  65 : watch-vars ( word vars -- )
  66     dupd [ (watch-vars) ] 2curry annotate ;
  67
  68 GENERIC# annotate-methods 1 ( word quot -- )
  69
  70 M: generic annotate-methods
  71     >r "methods" word-prop values r> [ annotate ] curry each ;
  72
  73 M: word annotate-methods
  74     annotate ;
  75
  76 : breakpoint ( word -- )
  77     [ add-breakpoint ] annotate-methods ;
  78
  79 : breakpoint-if ( word quot -- )
  80     [ [ [ break ] when ] rot 3append ] curry annotate-methods ;