basis/tools/trace/trace.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes combinators.short-circuit effects
   4 generic.math io io.styles kernel kernel.private make math.parser
   5 namespaces prettyprint quotations sequences strings summary
   6 tools.continuations words ;
   7 IN: tools.trace
   8
   9 <PRIVATE
  10
  11 : callstack-depth ( callstack -- n )
  12     callstack>array midpoint@ ;
  13
  14 SYMBOL: end
  15
  16 : into? ( obj -- ? )
  17     {
  18         [ word? ]
  19         [ predicate? not ]
  20         [ math-generic? not ]
  21         [
  22             [ inline? ]
  23             [ vocabulary>> { "math" "accessors" } member? not ] bi or
  24         ]
  25     } 1&& ;
  26
  27 TUPLE: trace-step-state word inputs ;
  28
  29 M: trace-step-state summary
  30     [
  31         [ "Word: " % word>> name>> % ]
  32         [ " -- inputs: " % inputs>> unparse-short % ] bi
  33     ] "" make ;
  34
  35 : <trace-step> ( continuation word -- trace-step )
  36     [ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* bound tail* ] 2bi
  37     \ trace-step-state boa ;
  38
  39 : print-step ( continuation -- )
  40     dup continuation-current dup word? [
  41         [ nip name>> ] [ <trace-step> ] 2bi write-object nl
  42     ] [
  43         nip short.
  44     ] if ;
  45
  46 : print-depth ( continuation -- )
  47     call>> callstack-depth
  48     [ CHAR: \s <string> write ]
  49     [ number>string write ": " write ] bi ;
  50
  51 : trace-into? ( continuation -- ? )
  52     continuation-current into? ;
  53
  54 : trace-step ( continuation -- continuation' )
  55     dup call>> innermost-frame-executing quotation? [
  56         dup continuation-current end eq? [
  57             [ print-depth ]
  58             [ print-step ]
  59             [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
  60             tri
  61         ] unless
  62     ] when ;
  63
  64 PRIVATE>
  65
  66 : trace ( quot -- data )
  67     [ [ trace-step ] break-hook ] dip
  68     [ break ] [ end drop ] surround
  69     with-variable ;
  70
  71 << \ trace t "no-compile" set-word-prop >>