modules/debug.st

   1 "
   2  Little Smalltalk, Version 5
   3
   4  Copyright (C) 1987-2005 by Timothy A. Budd
   5  Copyright (C) 2007 by Charles R. Childers
   6  Copyright (C) 2005-2007 by Danny Reinhold
   7  Copyright (C) 2010 by Ketmar // Vampire Avalon
   8
   9  ============================================================================
  10  This license applies to the virtual machine and to the initial image of
  11  the Little Smalltalk system and to all files in the Little Smalltalk
  12  packages except the files explicitly licensed with another license(s).
  13  ============================================================================
  14  Permission is hereby granted, free of charge, to any person obtaining a copy
  15  of this software and associated documentation files (the 'Software'), to deal
  16  in the Software without restriction, including without limitation the rights
  17  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  18  copies of the Software, and to permit persons to whom the Software is
  19  furnished to do so, subject to the following conditions:
  20
  21  The above copyright notice and this permission notice shall be included in
  22  all copies or substantial portions of the Software.
  23
  24  THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  25  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  26  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  27  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  28  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  29  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  30  DEALINGS IN THE SOFTWARE.
  31 "
  32 "debug.st - a simple interactive debugger for Tiny Smalltalk
  33  by Andy Valencia, May 2001
  34  heavily modified by Ketmar // Vampire Avalon
  35
  36  To use the debugger, fileIn: this file.  Then do:
  37
  38  Debug run: 'command...'
  39
  40  The given command line will be compiled (much as it would if you had
  41  typed it interactively).  Then the debugger will be started on this
  42  command itself.  Generally, you'll do a 's' (or 'step') to step down
  43  from the command line into the first method call.
  44 "
  45
  46
  47 Package [
  48   Debug
  49 ]
  50
  51 Requires [ disasm ]
  52
  53
  54 "======== String ========"
  55 String extend [
  56 asLines [
  57   | c ret slot idx base top nl s |
  58   "Convert a string with embedded newlines into an Array with one slot per line.
  59    The newlines are not a part of these lines."
  60   "Size the array of lines which will result"
  61   nl := Char newline.
  62   ret := Array new: (self occurencesOf: nl) + 1.
  63   "Walk the elements, assembling lines"
  64   slot := base := idx := 1.
  65   top := self size.
  66   [idx < top] whileTrue: [
  67     c := self at: idx.
  68     c = nl ifTrue: [
  69       (s := self from: base to: idx) ifNil: [ s := '' ].
  70       ret at: slot put: s removeTrailingBlanks.
  71       slot := slot + 1.
  72       base := idx + 1
  73     ].
  74     idx := idx + 1
  75   ].
  76   (idx > top) ifTrue: [ idx := top ].
  77   (idx > base) ifTrue: [
  78     (s := self from: base to: idx) ifNil: [ s := '' ].
  79     ret at: slot put: s removeTrailingBlanks.
  80   ].
  81   ^ret
  82 ]
  83 ]
  84
  85
  86 "======== Class ========"
  87 Class extend [
  88 setDebug: aMethodName [
  89   | meth cl dict |
  90   aMethodName := aMethodName asSymbol.
  91   "Chase up the superclass chain, trying to find our Method"
  92   cl := self. meth := nil.
  93   [ meth ] whileNil: [
  94     dict := cl methods.
  95     meth := dict at: aMethodName ifAbsent: [ cl := cl superclass. nil ].
  96     cl ifNil: [
  97       ('Undefined method ' + aMethodName + ' for class ' + self printString) printNl.
  98       ^nil
  99     ]
 100   ].
 101   "FIXME: certain methods for classes like Char can't be recompiled with debugger now"
 102   "cl == Char ifTrue: [ ^meth ]."
 103   "cl isMeta ifTrue: [ ^meth ]."  "debugger fails for MetaChar>>new: and maybe for others"
 104   ^meth
 105 ]
 106 ]
 107
 108
 109 "======== DebugMethodIFace ========"
 110 class: DebugMethodIFace [
 111 | mth textlines bpoints active |
 112 ^newFor: aMethod [
 113   | obj |
 114   obj := self new.
 115   self in: obj var: #mth put: aMethod.
 116   self in: obj var: #active put: false.
 117   ^obj
 118 ]
 119
 120 active [
 121   ^active
 122 ]
 123
 124 active: a [
 125   active := a
 126 ]
 127
 128 textlines [
 129   textlines ifNil: [ textlines := mth text asLines ].
 130   ^textlines
 131 ]
 132
 133 hasBreakAt: bp [
 134   bpoints ifNil: [ ^false ].
 135   ^bpoints includes: bp.
 136 ]
 137
 138 putBreakAt: bp value: old [
 139   bpoints ifNil: [ bpoints := Dictionary new ].
 140   bpoints at: bp put: old.
 141 ]
 142
 143 delBreakAt: bp [
 144   | res |
 145   bpoints ifNil: [ ^nil ].
 146   (bpoints includes: bp) ifFalse: [ ^nil ].
 147   res := bpoints at: bp.
 148   bpoints removeKey: bp.
 149   bpoints isEmpty ifTrue: [ bpoints := nil ].
 150   ^res
 151 ]
 152
 153 breakValueAt: bp [
 154   bpoints ifNil: [ ^nil ].
 155   (bpoints includes: bp) ifFalse: [ ^nil ].
 156   ^bpoints at: bp.
 157 ]
 158
 159 breakpoints [
 160   ^bpoints
 161 ]
 162 ]
 163
 164
 165 "======== Method ========"
 166 Method extend [
 167 setupDebugData [
 168   dbgData ifNil: [ dbgData := DebugMethodIFace newFor: self ]
 169 ]
 170
 171 textlines [
 172   self setupDebugData.
 173   ^dbgData textlines.
 174 ]
 175
 176 srcLine: bp [
 177   "map the VM instruction byte pointer onto a source line #"
 178   | line |
 179   (line := self findLineForPC: bp) ifNotNil: [ ^line ].
 180   'No match for ' print. bp printString printNl.
 181   ^nil
 182 ]
 183
 184 whatis: var in: ctx [
 185   "describe a variable in this method"
 186   | idx obj |
 187   obj := nil.
 188
 189   "special name"
 190   var = 'self' ifTrue: [
 191     var print. ' is a self reference' print.
 192     obj := ctx arguments at: 1.
 193     idx := 1.
 194   ].
 195
 196   "name of an argument"
 197   obj ifNil: [
 198     argNames ifNotNil: [
 199       (idx := argNames indexOfVal: var) ifNotNil: [
 200         idx := idx + 1.
 201         var print. ' is an argument' print.
 202         obj := ctx arguments at: idx.
 203       ]
 204     ]
 205   ].
 206
 207   "temporary"
 208   obj ifNil: [
 209     tempNames ifNotNil: [
 210       (idx := tempNames indexOfVal: var) ifNotNil: [
 211         var print. ' is a method variable' print.
 212         obj := ctx temporaries at: idx
 213       ]
 214     ]
 215   ].
 216
 217   "instance variable"
 218   obj ifNil: [
 219     (idx := (self forClass instanceVariables) indexOfVal: var) ifNotNil: [
 220       var print. ' is an instance variable' print.
 221       obj := ctx arguments at: 1.
 222       obj := (Object class in: obj at: idx)
 223     ]
 224   ].
 225
 226   "if we found it, display the generic information"
 227   obj ifNotNil: [
 228     ' (index ' print. idx print. ')' printNl.
 229     ' Value: ' print. obj printNl.
 230     ' Class: ' print. obj class printString print.
 231     ' basicSize: ' print. obj basicSize printNl.
 232   ] ifFalse: [
 233     "couldn't find it..."
 234     'Unknown variable: ' print. var printNl
 235   ]
 236 ]
 237
 238 getVar: var in: ctx ifAbsent: aBlock [
 239   "get a variable in this method, return its value"
 240   | idx |
 241   "special name"
 242   var = 'self' ifTrue: [ ^ctx arguments at: 1 ].
 243   "name of an argument"
 244   argNames ifNotNil: [ (idx := argNames indexOfVal: var) ifNotNil: [ ctx arguments at: idx + 1 ]].
 245   "temporary"
 246   tempNames ifNotNil: [ (idx := tempNames indexOfVal: var) ifNotNil: [ ctx temporaries at: idx ]].
 247   "instance variable"
 248   (idx := (self forClass instanceVariables) indexOfVal: var) ifNotNil: [
 249     var := ctx arguments at: 1.
 250     ^(Object class in: var at: idx)
 251   ].
 252   "couldn't find it..."
 253   ^aBlock value
 254 ]
 255
 256 getVar: var in: ctx [
 257   ^self getVar: var in: ctx ifAbsent: [ ^nil ]
 258 ]
 259
 260 print: var in: ctx [
 261   "print a variable in this method"
 262   | obj |
 263   obj := self getVar: var in: ctx ifAbsent: [ ('Unknown variable: ' + var) printNl. ^self ].
 264   obj printNl
 265 ]
 266
 267 setBreak: bp [
 268   "set a breakpoint in this method"
 269   | old |
 270   self setupDebugData.
 271   "if already set, ignore"
 272   (dbgData hasBreakAt: bp) ifTrue: [ ^self ].
 273   "record current opcode at code location and remember breakpoint"
 274   old := byteCodes at: bp + 1.
 275   dbgData putBreakAt: bp value: old.
 276   "update the code location if it's already active"
 277   dbgData active ifTrue: [ self patchBreak: bp active: true ].
 278 ]
 279
 280 clearBreak: bp [
 281   "remove a breakpoint in this method"
 282   self setupDebugData.
 283   "if not set, ignore"
 284   (dbgData hasBreakAt: bp) ifFalse: [ ^self ].
 285   "restore code contents"
 286   self patchBreak: bp active: false.
 287   "remove record of this breakpoint"
 288   dbgData delBreakAt: bp.
 289 ]
 290
 291 patchBreak: bp active: flag [
 292   "set or clear the breakpoint instruction in the code"
 293   flag ifTrue: [
 294     "patch in a DoSpecial operation 12 (breakpoint)"
 295     byteCodes at: (bp + 1) put: ((15*16) + 12).
 296   ] ifFalse: [
 297     "restore old code at this location"
 298     byteCodes at: (bp + 1) put: (dbgData breakValueAt: bp).
 299   ]
 300 ]
 301
 302 breakActive: flag [
 303   "activate or deactivate breakpoints for this method"
 304   | bpl |
 305   self setupDebugData.
 306   (bpl := dbgData breakpoints) ifNil: [ ^self ].
 307   "skip all this if we aren't changing settings"
 308   (dbgData active = flag) ifTrue: [ ^self ].
 309   "for each location with a breakpoint, update it"
 310   bpl keysDo: [:bp | self patchBreak: bp active: flag].
 311   dbgData active: flag.
 312 ]
 313
 314 codeLoc: line [
 315   "map source line # to a code location"
 316   ^self findPCForLine: line
 317 ]
 318
 319 browse: args [
 320   "get the DebugMethod, which has symbolic information for variables"
 321   '================' printNl.
 322   self forClass printString print. '>>' print. name printNl.
 323   '----------------' printNl.
 324   text printNl.
 325   '----------------' printNl.
 326 ]
 327
 328 internalPrintValue: obj [
 329   (obj isKindOf: Context)
 330     ifTrue: [
 331       '{' print. obj class print. '}' printNl.
 332     ] ifFalse: [
 333       obj printNl.
 334     ].
 335 ]
 336
 337 printAllVarsIn: ctx [
 338   | iv cls |
 339   '=========' printNl.
 340   argNames ifNotNil: [
 341     'arguments:' printNl.
 342     1 to: argNames size do: [:idx |
 343       ' ' print. (argNames at: idx) print. ' = ' print.
 344       self internalPrintValue: (ctx arguments at: idx + 1).
 345     ]
 346   ].
 347   tempNames ifNotNil: [
 348     'method vars:' printNl.
 349     1 to: tempNames size do: [:idx |
 350       ' ' print. (tempNames at: idx) print. ' = ' print.
 351       self internalPrintValue: (ctx temporaries at: idx).
 352     ]
 353   ].
 354   iv := self forClass instanceVariables.
 355   iv isEmpty ifFalse: [
 356     cls := ctx arguments at: 1.
 357     'instance vars:' printNl.
 358     1 to: iv size do: [:idx |
 359       ' ' print. (iv at: idx) print. ' = ' print.
 360       self internalPrintValue: (self in: cls at: idx).
 361     ]
 362   ].
 363   '---------' printNl.
 364 ]
 365
 366 debugOn [
 367 ]
 368 ]
 369
 370
 371 "======== Debug ========"
 372 Object subclass: Debug [
 373 | proc bpoints prevList selctx  lastDbgWarnMethod |
 374
 375 runIt: count [
 376   | ret |
 377   "blow away any selected context when we run"
 378   selctx := nil.
 379   "execute for one instruction
 380    return whether or not the return was 'normal' (i.e., VM stopped due to debugger control, not something else)
 381    spit out a message for a breakpoint"
 382   ret := proc doExecute: count + 1.
 383   (ret = 5) ifTrue: [ ^true ].
 384   (ret = 6) ifTrue: [ self onBreak. ^true ].
 385   (ret = 2) ifTrue: [ 'Error trap' printNl ].
 386   (ret = 3) ifTrue: [ 'Message not understood' printNl ].
 387   (ret = 4) ifTrue: [ 'Method returned' printNl ].
 388   (ret = 7) ifTrue: [ self error: 'DEBUGGER ERROR: no "yiled" processing yet' ].
 389   ^false
 390 ]
 391
 392 srcLine: ctx [
 393   "get source line corresponding to current byte pointer"
 394   ^(ctx method) srcLine: ctx bytePointer.
 395 ]
 396
 397 showLine: ctx [
 398   "show source line corresponding to current VM instruction of a given context"
 399   | line meth |
 400   ctx ifNil: [ ^nil ].
 401   meth := ctx method.
 402   line := self srcLine: ctx.
 403   line
 404     ifNil: [
 405       'Method ' print.  meth name print.
 406       ' for class ' print.  meth forClass print.
 407       ': no source displayed.' printNl
 408     ]
 409     ifNotNil: [
 410       ' ' print. line print. ': ' print.
 411       (meth textlines at: line ifAbsent: ['']) printNl
 412     ].
 413 ]
 414
 415 showLine [
 416   "display current line of active procedure"
 417   ^self showLine: self curContext
 418 ]
 419
 420 ^run: line [
 421   "run a command line under the debugger"
 422   | meth ret ctx proc |
 423   meth := (LstCompiler new text: ('debugCmd ^' + line) instanceVars: #()) compileWithClass: Undefined.
 424   meth ifNotNil: [
 425     meth debugOn.
 426     ret := super new.
 427     ctx := Context new.
 428     ctx setup: meth withArguments: (Array new: 1).
 429     proc := Process new.
 430     proc context: ctx.
 431     ret proc: proc.
 432     ret run.
 433   ]
 434 ]
 435
 436 proc: p [
 437   "initialize our new debug session"
 438   proc := p.
 439   bpoints := Array new: 0.
 440 ]
 441
 442 atCall [
 443   "tell if the VM instruction pointer is at a method invocation"
 444   "TODO: process unary and binary messages"
 445   | ret meth ctx pc low high |
 446   "get the next instruction"
 447   ctx := proc context.
 448   meth := ctx method.
 449   pc := ctx bytePointer.
 450   high := meth byteCodes at: (pc + 1) ifAbsent: [ ^nil ].
 451   pc := pc + 1.
 452   low := high % 16.
 453   high := high / 16.
 454   (high = 0) ifTrue: [
 455     high := low.
 456     low := meth byteCodes at: (pc + 1) ifAbsent: [ ^nil ].
 457     pc := pc + 1
 458   ].
 459   "return nil if it isn't a SendMessage"
 460   (high = 9) ifFalse: [ ^nil ].
 461   "otherwise return the selector and return address"
 462   ret := Array new: 2.
 463   ret at: 1 put: (meth literals at: (low + 1)).
 464   ret at: 2 put: pc.
 465   ^ret
 466 ]
 467
 468 stepCall: sel [
 469   "set up to step into a new method"
 470   | ctx stack sp args target meth |
 471   ctx := proc context.
 472   stack := ctx stack.
 473   sp := ctx stackTop.
 474   args := stack at: sp.
 475   target := args at: 1.
 476   meth := target class setDebug: sel.
 477   meth ifNil: [ ^true ].
 478   (self runIt: 1) ifFalse: [
 479     'Execution done in ' print.
 480     meth name print.
 481     ' of class ' print.
 482     target class printNl.
 483     ^true
 484   ].
 485   ^false
 486 ]
 487
 488 onBreak [
 489   "tell if we're at a breakpoint; as a side effect, display this fact to the user"
 490   | ctx meth rec |
 491   ctx := proc context.
 492   ctx ifNil: [ ^false ].
 493   meth := ctx method.
 494   1 to: bpoints size do: [:idx|
 495     rec := bpoints at: idx.
 496     (((rec at: 1) = meth) and:
 497         [(rec at: 2) = (self srcLine: ctx)])
 498     ifTrue: [
 499       'Breakpoint ' print. idx print. ' hit in ' print.
 500       meth name printString print. '/' print.
 501       (rec at: 2) printNl.
 502       ^true
 503     ]
 504   ].
 505   ^false
 506 ]
 507
 508 overCall: pc [
 509   "set a breakpoint at the instruction beyond the SendMessage"
 510   | ctx res meth |
 511   ctx := proc context.
 512   "if we're within a non-debug method, just limp forward"
 513 "
 514   (self isDebugMethod: (meth := ctx method)) ifFalse: [
 515     'doing single stepping' printNl.
 516     self runIt: 1.
 517     ^false
 518   ].
 519 "
 520   meth := ctx method.
 521   "otherwise break beyond the call"
 522   meth setBreak: pc.
 523   "now let it run until it hits the breakpoint, and clear the breakpoint"
 524   self breakActive: true. meth breakActive: true.
 525   res := self runIt: -1.
 526   self breakActive: false.  meth clearBreak: pc.
 527   res ifTrue: [
 528     "should be stopped at the expected location"
 529     ((proc context = ctx) and: [ ctx bytePointer = pc ]) ifTrue: [ ^false ].
 530     "or hit some other breakpoint"
 531     (self onBreak) ifTrue: [ ^false ].
 532     "otherwise, what's going on?"
 533     'Unexpected run completion' printNl.
 534     ^true
 535   ].
 536   "some other error killed us"
 537   'Execution aborted' printNl.
 538   ^true
 539 ]
 540
 541 doStep: intoCalls [
 542   "implement a single step, stepping either over or into calls (method invocations) depending on the intoCalls argument"
 543   | srcl ret ctx |
 544   ctx := proc context.
 545   srcl := self srcLine: ctx.
 546   [(proc context == ctx) and: [srcl == (self srcLine: ctx)]] whileTrue: [
 547     "if dropping into a new method, deal with it"
 548     ret := self atCall.
 549     ret ifNotNil: [
 550       "stepping into the call"
 551       intoCalls ifTrue: [ ^self stepCall: (ret at: 1) ].
 552       "stepping over call"
 553       (self overCall: (ret at: 2)) ifTrue: [ ^true ].
 554     ] ifNil: [
 555       "otherwise run a single VM operation"
 556       (self runIt: 1) ifFalse: [
 557         'Execution done at line ' print. srcl printString printNl.
 558         ^true
 559       ]
 560     ]
 561   ].
 562   ^false
 563 ]
 564
 565 printReg: reg in: ctx [
 566   "print a VM register"
 567   (reg = '$pc') ifTrue: [ ctx bytePointer print. ^self ].
 568   (reg = '$sp') ifTrue: [ ctx stackTop print. ^self ].
 569   'Unknown register: ' print. reg print
 570 ]
 571
 572 curContext [
 573   selctx ifNil: [ ^proc context ].
 574   ^selctx
 575 ]
 576
 577 whatis: args [
 578   "display arguments, temporaries, instance variables, and VM registers"
 579   | ctx meth |
 580   "get the DebugMethod, which has symbolic information for variables"
 581   ctx := self curContext.
 582   "(self isDebugMethod: (meth := ctx method)) ifFalse: [ ^nil ]."
 583   meth := ctx method.
 584   "walk each variable, printing its value"
 585   args do: [:var |
 586     var print. ': ' print.
 587     ((var at: 1) == $$)
 588     ifTrue: [
 589       var print. ' is a register variable' printNl.
 590     ] ifFalse: [
 591       meth whatis: var in: ctx
 592     ]
 593   ]
 594 ]
 595
 596 examine: args [
 597   "display arguments, temporaries, instance variables, and VM registers"
 598   | ctx meth |
 599   "get the DebugMethod, which has symbolic information for variables"
 600   ctx := self curContext.
 601   "(self isDebugMethod: (meth := ctx method)) ifFalse: [ ^nil ]."
 602   meth := ctx method.
 603   "walk each variable, printing its value"
 604   args do: [:var |
 605     var print. ': ' print.
 606     ((var at: 1) == $$)
 607     ifTrue: [
 608       self printReg: var in: ctx
 609     ] ifFalse: [
 610       meth print: var in: ctx
 611     ].
 612     '\n' print.
 613   ]
 614 ]
 615
 616 setBreak: args [
 617   "set a breakpoint"
 618   | s cl clname meth methname i rec lineNum inClass arg loc |
 619   "map straight line # to current class/method"
 620   arg := args at: 1.
 621   ((arg at: 1) isDigit) ifTrue: [
 622     lineNum := arg asNumber.
 623     lineNum ifNil: [
 624       'Bad line #' print. arg printNl.
 625       ^nil
 626     ].
 627     meth := self curContext method.
 628     arg := (meth forClass printString) + '/' + (meth name printString) + '/' + lineNum printString.
 629   ].
 630   "parse <class>:<method>"
 631   s := arg break: '/'.
 632   (s size < 2) ifTrue: [
 633     'Format is <class>/<method>' printNl.
 634     ^nil
 635   ].
 636   "look up in instance methods unless it's Meta<class>, in which case trim the 'Meta' and look up in class methods"
 637   clname := s at: 1.
 638   ((clname from: 1 to: 4) = 'Meta') ifTrue: [
 639     inClass := true.
 640     clname := clname from: 5 to: clname size
 641   ] ifFalse: [
 642     inClass := false
 643   ].
 644   clname := clname asSymbol.
 645   methname := (s at: 2) asSymbol.
 646   "parse line number"
 647   (s size > 2) ifTrue: [
 648     lineNum := (s at: 3) asNumber.
 649     lineNum ifNil: [
 650       'Bad line #' print. (s at: 3) printNl.
 651       ^nil
 652     ]
 653   ] ifFalse: [
 654     lineNum := 1
 655   ].
 656   "find class"
 657   cl := Smalltalk at: clname ifAbsent: [
 658     ('Unknown class: ' + clname printString) printNl.
 659     ^nil
 660   ].
 661   "convert to metaclass if needed"
 662   inClass ifTrue: [ cl := cl class ].
 663   "now get method, in its debuggable format"
 664   meth := cl setDebug: methname.
 665   meth ifNil: [
 666     ('Unknown method: ' + methname printString) printNl.
 667     ^nil
 668   ].
 669   "(self isDebugMethod: meth) ifFalse: [ ^nil ]."
 670   "if it's already set, don't do it again"
 671   rec := Array with: meth with: lineNum.
 672   i := bpoints indexOfVal: rec.
 673   i ifNotNil: [
 674     'Already set as breakpoint ' print.
 675     i printNl.
 676     ^nil
 677   ].
 678   "see if we can turn line # into a code location"
 679   loc := meth codeLoc: lineNum.
 680   loc ifNil: [
 681     'No code for source line ' print. lineNum printNl.
 682     ^nil
 683   ].
 684   "set & record the breakpoint"
 685   meth setBreak: loc.
 686   bpoints := bpoints with: rec
 687 ]
 688
 689 clearBreak: args [
 690   "delete an existing breakpoint"
 691   | arg n rec meth lineNum |
 692   arg := args at: 1 ifAbsent: ['Missing argument' printNl. ^nil].
 693   n := arg asNumber.
 694   n ifNil: [
 695     ('Invalid argument: ' + arg) printNl
 696   ] ifNotNil: [
 697     ((n < 1) or: [n > bpoints size]) ifTrue: [
 698       ('No such breakpoint: ' + arg) printNl
 699     ] ifFalse: [
 700       rec := bpoints at: n.
 701       meth := rec at: 1.
 702       lineNum := rec at: 2.
 703       meth clearBreak: (meth codeLoc: lineNum).
 704       bpoints := bpoints removeIndex: n.
 705       n print. ': deleted' printNl
 706     ]
 707   ]
 708 ]
 709
 710 listBreak [
 711   "list breakpoints"
 712   | rec meth lineNum |
 713   'Breakpoints:' printNl.
 714   1 to: bpoints size do: [:x|
 715     x print. ': ' print.
 716     rec := bpoints at: x.
 717     meth := rec at: 1.
 718     lineNum := rec at: 2.
 719     meth name printString print. '/' print.
 720     lineNum printNl
 721   ]
 722 ]
 723
 724 breakActive: flag [
 725   "make all our breakpoints active or inactive, depending on flag's value"
 726   | meths |
 727   meths := Set new.
 728   bpoints do: [:rec|
 729     meths add: (rec at: 1)
 730   ].
 731   meths do: [:meth| meth breakActive: flag]
 732 ]
 733
 734 list: args [
 735   "list source code"
 736   | meth where src ctx |
 737   "get the method we're going to display"
 738   ctx := self curContext.
 739   "(self isDebugMethod: (meth := ctx method)) ifFalse: [ ^self ]."
 740   meth := ctx method.
 741   "either continue listing, or start from the given place"
 742   (args size < 1) ifTrue: [
 743     prevList ifNil: [
 744       "list around where we're currently executing"
 745       where := (self srcLine: ctx) - 5
 746     ] ifNotNil: [
 747       where := prevList + 1
 748     ]
 749   ] ifFalse: [
 750     where := (args at: 1) asNumber.
 751     where ifNil: [
 752       'Invalid line number: ' print.
 753       (args at: 1) printNl.
 754       ^self
 755     ]
 756   ].
 757   "show 9 lines"
 758   src := meth textlines.
 759   where to: (where + 8) do: [:x|
 760     ((x > 0) and: [x <= src size]) ifTrue: [
 761       (x printString printWidth: 8) print.
 762       (src at: x) printNl.
 763       prevList := x
 764     ]
 765   ]
 766 ]
 767
 768 nextContext: ctx [
 769   "return next context deeper in context stack
 770    because contexts are only forward linked, we have to search from the top inward, then return the next one out"
 771   | c prev |
 772   c := proc context.
 773   [(prev := c previousContext) ~= ctx] whileTrue: [
 774     prev ifNil: [ ^nil ].
 775     c := prev
 776   ].
 777   ^c
 778 ]
 779
 780 upDown: up count: args [
 781   "move up or down the stack frames"
 782   | c count |
 783   "if nothing selected, start from bottom of stack"
 784   selctx := self curContext.
 785   "get count, default 1"
 786   (args size > 0) ifTrue: [
 787     count := (args at: 1) asNumber
 788   ] ifFalse: [
 789     count := 1
 790   ].
 791   "walk the context chain"
 792   1 to: count do: [:ignore |
 793     "get next/prev context depending on step direction"
 794     up ifTrue: [
 795       c := selctx previousContext
 796     ] ifFalse: [
 797       c := self nextContext: selctx
 798     ].
 799     "just ignore running off the end"
 800     c ifNotNil: [ selctx := c ]
 801   ]
 802 ]
 803
 804 makeDebug: args [
 805   "convert Class methods to DebugMethod's"
 806   | cl meta n |
 807   ^self
 808   args do: [:clname |
 809     "map MetaFOO -> FOO class"
 810     ((clname from: 1 to: 4) = 'Meta') ifTrue: [
 811       n := clname from: 5.
 812       meta := true
 813     ] ifFalse: [
 814       n := clname.
 815       meta := false
 816     ].
 817     "look up class"
 818     cl := Smalltalk at: n asSymbol ifAbsent: [ nil ].
 819     cl
 820      ifNil: [ ('Unknown class: ' + clname) printNl ]
 821      ifNotNil: [
 822       "map to metaclass if needed"
 823       meta ifTrue: [ cl := cl class ].
 824       "convert methods"
 825       cl methods keysDo: [:k | cl setDebug: k ]
 826      ]
 827   ]
 828 ]
 829
 830
 831 showHelp [
 832   'available debugger commands' printNl.
 833   '---------------------------' printNl.
 834   's  step\n   single step to the next line' printNl.
 835   'si  stepi\n   single step one VM instruction' printNl.
 836   'n  next\n   step over method calls on the current line' printNl.
 837   'b <class>/<method>[/<line #>]  break <class>/<method>[/<line #>]' printNl.
 838     '   set a breakpoint at the named method.' printNl.
 839     '   meta<class> accesses class methods.' printNl.
 840     '   a plain line number applies to the current class/method.' printNl.
 841   'c  cont\n   continue running until error, completion, or breakpoint.' printNl.
 842   'd int  delete int\n   delete breakpoint.' printNl.
 843   'lb  listbreak\n   list breakpoints.' printNl.
 844   'p varlist  print varlist\n   print variable(s).' printNl.
 845     '   You may also use $pc (VM instruction pointer) and $sp (VM stack top pointer).' printNl.
 846   'q  quit\n   leave the debugger (abandon the executing target code).' printNl.
 847   'where  bt\n   show stack backtrace.' printNl.
 848   'l [line]  list [line]\n   list source (can provide a line # as argument).' printNl.
 849   'whatis\n   describe variable more thoroughly.' printNl.
 850   'up  down\n   move up and down the call stack for purposes of accessing variables.' printNl.
 851   'debug class\n   compiles all method''s for that class in their debuggable form.' printNl.
 852   'br  browse\n   invokes system data structure browser.' printNl.
 853   'di  disasm\n   disassemble current method.' printNl.
 854   'allvars\n   show all variables.' printNl.
 855   '(blank line)\n   re-enter previous command.  Useful for single stepping statements in a row.' printNl.
 856 ]
 857
 858 run [
 859   "main command loop for the debugger session"
 860   | prev did cmd done line  ctx meth goodpt |
 861   prev := 's'.
 862   done := false.
 863   [ true ] whileTrue: [
 864     (ctx := self curContext) ifNil: [ ^nil ].
 865     (meth := ctx method) ifNil: [ ^nil ].
 866     goodpt := true.
 867     (ctx := selctx)
 868       ifNil: [ ctx := self curContext ]
 869       ifNotNil: [
 870         (meth = ctx method) ifNil: [ meth := (ctx := self curContext) method. ].
 871       ].
 872     goodpt ifTrue: [
 873       "show disassembled line"
 874       ' ' print. meth disassemble: 0 at: ctx bytePointer for: 1.
 875       "show where we are"
 876       self showLine.
 877       "show prompt"
 878       meth forClass printString print. '>>' print. meth name print.
 879       '(' print. ((ctx bytePointer) printWidth: 4) print. ')' print.
 880       ' | ' print.
 881     ] ifFalse: [
 882       'Debug> ' print.
 883     ].
 884     "get command"
 885     line := String input.
 886     "re-insert previous command if empty line"
 887     (line isEmpty) ifTrue: [ line := prev ].
 888     prev := line.
 889     "parse into words"
 890     line := line break: ' \t\n\r'.
 891     "command is first, arguments follow"
 892     cmd := line at: 1.
 893     line := line from: 2 to: line size.
 894     "set flag to indicate command hasn't matched yet"
 895     did := false.
 896     "step a single VM instruction"
 897     (((cmd = '?') or: [ cmd = 'h' ]) or: [ cmd = 'help' ]) ifTrue: [ self showHelp. did := true ].
 898     ((cmd = 'si') or: [ cmd = 'stepi' ]) ifTrue: [
 899       done
 900        ifTrue: [ 'Not runnable' printNl ]
 901        ifFalse: [
 902         prevList := nil.
 903         (self runIt: 1) ifFalse: [
 904           done := true
 905         ]
 906       ].
 907       did := true
 908     ].
 909     "step a source line"
 910     ((cmd = 'step') or: [cmd = 's']) ifTrue: [
 911       done
 912        ifTrue: [ 'Not runnable' printNl ]
 913        ifFalse: [
 914          prevList := nil.
 915          done := self doStep: true
 916        ].
 917       did := true
 918     ].
 919     "step a source line, stepping over message sends"
 920     ((cmd = 'next') or: [cmd = 'n']) ifTrue: [
 921       done
 922        ifTrue: [ 'Not runnable' printNl ]
 923        ifFalse: [
 924          prevList := nil.
 925          done := self doStep: false
 926        ].
 927       did := true.
 928     ].
 929     "examine variables"
 930     ((cmd = 'p') or: [cmd = 'print']) ifTrue: [
 931       self examine: line.
 932       did := true
 933     ].
 934     "describe variable"
 935     (cmd = 'whatis') ifTrue: [
 936       self whatis: line.
 937       did := true
 938     ].
 939     "set a breakpoint"
 940     ((cmd = 'b') or: [cmd = 'break']) ifTrue: [
 941       self setBreak: line.
 942       did := true
 943     ].
 944
 945     "clear breakpoint(s)"
 946     ((cmd = 'd') or: [cmd = 'delete']) ifTrue: [
 947       self clearBreak: line.
 948       did := true
 949     ].
 950     "list breakpoints"
 951     ((cmd = 'lb') or: [cmd = 'listbreak']) ifTrue: [
 952       self listBreak.
 953       did := true
 954     ].
 955     "just let it run"
 956     ((cmd = 'cont') or: [cmd = 'c']) ifTrue: [
 957       "clear previous listing position"
 958       prevList := nil.
 959       "step forward once, even over a breakpoint"
 960       done := (self runIt: 1) not.
 961       "now run until completion or next break"
 962       done ifFalse: [
 963         "activate, run, and deactivate"
 964         self breakActive: true.
 965         done := (self runIt: -1) not.
 966         self breakActive: false.
 967         "display a message if hit a breakpoint"
 968         done ifFalse: [ self onBreak ].
 969       ].
 970       did := true
 971     ].
 972     "source listing"
 973     ((cmd = 'l') or: [cmd = 'list']) ifTrue: [
 974       self list: line.
 975       did := true
 976     ].
 977     "abandon the method"
 978     ((cmd = 'q') or: [cmd = 'quit']) ifTrue: [
 979       ^nil
 980     ].
 981     "stack backtrace"
 982     ((cmd = 'where') or: [cmd = 'bt']) ifTrue: [
 983       proc context
 984       ifNil: [
 985         'Process has terminated' printNl
 986       ] ifNotNil: [
 987         proc context backtrace
 988       ].
 989       did := true
 990     ].
 991     "go up or down the stack chain"
 992     ((cmd = 'up') or: [cmd = 'down']) ifTrue: [
 993       self upDown: (cmd = 'up') count: line.
 994       did := true
 995     ].
 996     "make all procedures of the named class debuggable"
 997     (cmd = 'debug') ifTrue: [
 998       self makeDebug: line.
 999       did := true
1000     ].
1001     "hook to data structure browser"
1002     ((cmd = 'br') or: [cmd = 'browse']) ifTrue: [
1003       self browse: line.
1004       did := true
1005     ].
1006     "disassemble"
1007     ((cmd = 'di') or: [cmd = 'disasm']) ifTrue: [
1008       meth disassemble.
1009       did := true
1010     ].
1011     (cmd = 'allvars') ifTrue: [
1012       meth printAllVarsIn: ctx.
1013       did := true
1014     ].
1015     "error"
1016     did ifFalse: [ 'Unknown command.' printNl ].
1017   ]
1018 ]
1019
1020 browse: args [
1021   | meth ctx |
1022   "get the DebugMethod, which has symbolic information for variables"
1023   ctx := self curContext.
1024   "(self isDebugMethod: (meth := ctx method)) ifFalse: [ ^nil ]."
1025   meth := ctx method.
1026   meth forClass printString print. '>>' print. meth name printNl.
1027   meth browse: args.
1028 ]
1029 ]