git.chise.org Git - chise/xemacs-chise.git-/blob - src/dbxrc

   1 # -*- ksh -*-
   2 # Copyright (C) 1998 Free Software Foundation, Inc.
   3
   4 # This file is part of XEmacs.
   5
   6 # XEmacs is free software; you can redistribute it and/or modify it
   7 # under the terms of the GNU General Public License as published by the
   8 # Free Software Foundation; either version 2, or (at your option) any
   9 # later version.
  10
  11 # XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 # for more details.
  15
  16 # You should have received a copy of the GNU General Public License
  17 # along with XEmacs; see the file COPYING.  If not, write to
  18 # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 # Boston, MA 02111-1307, USA.
  20
  21 # Author: Martin Buchholz
  22
  23 # You can use this file to debug XEmacs using Sun WorkShop's dbx.
  24 # Add the contents of this file to $HOME/.dbxrc or
  25 # Source the contents of this file with something like:
  26 # if test -r ./dbxrc; then . ./dbxrc; fi
  27
  28 # Some functions defined here require a running process, but most
  29 # don't.  Considerable effort has been expended to this end.
  30
  31 # See also the comments in gdbinit.
  32
  33 # See also the question of the XEmacs FAQ, titled
  34 # "How to Debug an XEmacs problem with a debugger".
  35
  36 ignore POLL
  37 ignore IO
  38
  39 document lbt << 'end'
  40 Usage: lbt
  41 Print the current Lisp stack trace.
  42 Requires a running xemacs process.
  43 end
  44
  45 function lbt {
  46   call debug_backtrace()
  47 }
  48
  49 document ldp << 'end'
  50 Usage: ldp lisp_object
  51 Print a Lisp Object value using the Lisp printer.
  52 Requires a running xemacs process.
  53 end
  54
  55 function ldp {
  56   call debug_print ($1);
  57 }
  58
  59 # A bug in dbx prevents string variables from having values beginning with `-'!!
  60 function XEmacsInit {
  61   function ToInt { eval "$1=\$[(int) $1]"; }
  62   ToInt dbg_USE_MINIMAL_TAGBITS
  63   ToInt dbg_USE_UNION_TYPE
  64   ToInt dbg_USE_INDEXED_LRECORD_IMPLEMENTATION
  65   ToInt Lisp_Type_Int
  66   ToInt Lisp_Type_Char
  67   ToInt Lisp_Type_Cons
  68   ToInt Lisp_Type_String
  69   ToInt Lisp_Type_Vector
  70   ToInt Lisp_Type_Symbol
  71   ToInt Lisp_Type_Record
  72   ToInt dbg_valbits
  73   ToInt dbg_gctypebits
  74   function ToLong { eval "$1=\$[(unsigned long) $1]"; }
  75   ToLong dbg_valmask
  76   ToLong dbg_typemask
  77   xemacs_initted=yes
  78 }
  79
  80 function printvar {
  81   for i in $*; do eval "echo $i=\$$i"; done
  82 }
  83
  84 document decode_object << 'end'
  85 Usage: decode_object lisp_object
  86 Extract implementation information from a Lisp Object.
  87 Defines variables $val, $type and $imp.
  88 end
  89
  90 # Various dbx bugs cause ugliness in following code
  91 function decode_object {
  92   if test -z "$xemacs_initted"; then XEmacsInit; fi;
  93   if test $dbg_USE_UNION_TYPE = 1; then
  94     # Repeat after me... dbx sux, dbx sux, dbx sux...
  95     # Allow both `pobj Qnil' and `pobj 0x82746834' to work
  96     case $(whatis $1) in
  97       *Lisp_Object*) obj="$[(unsigned long)(($1).i)]";;
  98       *) obj="$[(unsigned long)($1)]";;
  99     esac
 100   else
 101     obj="$[(unsigned long)($1)]";
 102   fi
 103   if test $dbg_USE_MINIMAL_TAGBITS = 1; then
 104     if test $[(int)($obj & 1)] = 1; then
 105       # It's an int
 106       val=$[(long)(((unsigned long long)$obj) >> 1)]
 107       type=$Lisp_Type_Int
 108     else
 109       type=$[(int)(((void*)$obj) & $dbg_typemask)]
 110       if test $type = $Lisp_Type_Char; then
 111         val=$[(void*)(long)(((unsigned long long)($obj & $dbg_valmask)) >> $dbg_gctypebits)]
 112       else
 113         # It's a record pointer
 114         val=$[(void*)$obj]
 115         if test "$val" = "(nil)"; then type=null_pointer; fi
 116       fi
 117     fi
 118   else
 119     # not dbg_USE_MINIMAL_TAGBITS
 120     type=$[(int)(((unsigned long long)($obj & $dbg_typemask)) >> ($dbg_valbits + 1))]
 121     if test "$type" = $Lisp_Type_Int; then
 122       val=$[(int)($obj & $dbg_valmask)]
 123     elif test "$type" = $Lisp_Type_Char; then
 124       val=$[(int)($obj & $dbg_valmask)]
 125     else
 126       val=$[(void*)($obj & $dbg_valmask)]
 127       if test "$val" = "(nil)"; then type=null_pointer; fi
 128     fi
 129     #val=$[(void*)($obj & $dbg_valmask)]
 130     #printvar val type obj
 131   fi
 132
 133   if test $type = $Lisp_Type_Record; then
 134     typeset lheader="((struct lrecord_header *) $val)"
 135     if test $dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1; then
 136       imp=$[(void*)(lrecord_implementations_table[$lheader->type])]
 137     else
 138       imp=$[(void*)($lheader->implementation)]
 139     fi
 140   else
 141     imp="0xdeadbeef"
 142   fi
 143   # printvar obj val type imp
 144 }
 145
 146 function xint {
 147   decode_object "$*"
 148   print (long) ($val)
 149 }
 150
 151 function xtype {
 152   decode_object "$*"
 153   if   test $type = $Lisp_Type_Int;    then echo "int"
 154   elif test $type = $Lisp_Type_Char;   then echo "char"
 155   elif test $type = $Lisp_Type_Symbol; then echo "symbol"
 156   elif test $type = $Lisp_Type_String; then echo "string"
 157   elif test $type = $Lisp_Type_Vector; then echo "vector"
 158   elif test $type = $Lisp_Type_Cons;   then echo "cons"
 159   elif test $type = null_pointer;      then echo "null_pointer"
 160   else
 161     echo "record type with name: $[((struct lrecord_implementation *)$imp)->name]"
 162   fi
 163 }
 164
 165 function lisp-shadows {
 166   run -batch -vanilla -f list-load-path-shadows
 167 }
 168
 169 function environment-to-run-temacs {
 170   unset EMACSLOADPATH
 171   export EMACSBOOTSTRAPLOADPATH=../lisp/:..
 172   export EMACSBOOTSTRAPMODULEPATH=../modules/:..
 173 }
 174
 175 document run-temacs << 'end'
 176 Usage: run-temacs
 177 Run temacs interactively, like xemacs.
 178 Use this with debugging tools (like purify) that cannot deal with dumping,
 179 or when temacs builds successfully, but xemacs does not.
 180 end
 181
 182 function run-temacs {
 183   environment-to-run-temacs
 184   run -batch -l ../lisp/loadup.el run-temacs -q
 185 }
 186
 187 document update-elc << 'end'
 188 Usage: update-elc
 189 Run the core lisp byte compilation part of the build procedure.
 190 Use when debugging temacs, not xemacs!
 191 Use this when temacs builds successfully, but xemacs does not.
 192 end
 193
 194 function update-elc {
 195   environment-to-run-temacs
 196   run -batch -l ../lisp/update-elc.el
 197 }
 198
 199
 200 function dump-temacs {
 201   environment-to-run-temacs
 202   run -batch -l ../lisp/loadup.el dump
 203 }
 204
 205 document dump-temacs << 'end'
 206 Usage: dump-temacs
 207 Run the dumping part of the build procedure.
 208 Use when debugging temacs, not xemacs!
 209 Use this when temacs builds successfully, but xemacs does not.
 210 end
 211
 212 function pstruct {
 213   xstruct="((struct $1 *) $val)"
 214   print $xstruct
 215   print *$xstruct
 216 }
 217
 218 function lrecord_type_p {
 219   if eval test -z \"\$lrecord_$1\" && test $imp = $[(void*)(&lrecord_$1)]; then return 0; else return 1; fi
 220 }
 221
 222 document pobj << 'end'
 223 Usage: pobj lisp_object
 224 Print the internal C structure of a underlying Lisp Object.
 225 end
 226
 227 function pobj {
 228   decode_object $1
 229   if test $type = $Lisp_Type_Int; then
 230     print -f"Integer: %d" $val
 231   elif test $type = $Lisp_Type_Char; then
 232     if test $[$val > 32 && $val < 128] = 1; then
 233       print -f"Char: %c" $val
 234     else
 235       print -f"Char: %d" $val
 236     fi
 237   elif test $type = $Lisp_Type_String || lrecord_type_p string; then
 238     pstruct Lisp_String
 239   elif test $type = $Lisp_Type_Cons   || lrecord_type_p cons; then
 240     pstruct Lisp_Cons
 241   elif test $type = $Lisp_Type_Symbol || lrecord_type_p symbol; then
 242     pstruct Lisp_Symbol
 243     echo "Symbol name: $[(char *)($xstruct->name->data)]"
 244   elif test $type = $Lisp_Type_Vector || lrecord_type_p vector; then
 245     pstruct Lisp_Vector
 246     echo "Vector of length $[$xstruct->size]"
 247   elif lrecord_type_p bit_vector; then
 248     pstruct Lisp_Bit_Vector
 249   elif lrecord_type_p buffer; then
 250     pstruct buffer
 251   elif lrecord_type_p char_table; then
 252     pstruct Lisp_Char_Table
 253   elif lrecord_type_p char_table_entry; then
 254     pstruct Lisp_Char_Table_Entry
 255   elif lrecord_type_p charset; then
 256     pstruct Lisp_Charset
 257   elif lrecord_type_p coding_system; then
 258     pstruct Lisp_Coding_System
 259   elif lrecord_type_p color_instance; then
 260     pstruct Lisp_Color_Instance
 261   elif lrecord_type_p command_builder; then
 262     pstruct command_builder
 263   elif lrecord_type_p compiled_function; then
 264     pstruct Lisp_Compiled_Function
 265   elif lrecord_type_p console; then
 266     pstruct console
 267   elif lrecord_type_p database; then
 268     pstruct Lisp_Database
 269   elif lrecord_type_p device; then
 270     pstruct device
 271   elif lrecord_type_p event; then
 272     pstruct Lisp_Event
 273   elif lrecord_type_p extent; then
 274     pstruct extent
 275   elif lrecord_type_p extent_auxiliary; then
 276     pstruct extent_auxiliary
 277   elif lrecord_type_p extent_info; then
 278     pstruct extent_info
 279   elif lrecord_type_p face; then
 280     pstruct Lisp_Face
 281   elif lrecord_type_p float; then
 282     pstruct Lisp_Float
 283   elif lrecord_type_p font_instance; then
 284     pstruct Lisp_Font_Instance
 285   elif lrecord_type_p frame; then
 286     pstruct frame
 287   elif lrecord_type_p glyph; then
 288     pstruct Lisp_Glyph
 289   elif lrecord_type_p hash_table; then
 290     pstruct Lisp_Hash_Table
 291   elif lrecord_type_p image_instance; then
 292     pstruct Lisp_Image_Instance
 293   elif lrecord_type_p keymap; then
 294     pstruct Lisp_Keymap
 295   elif lrecord_type_p lcrecord_list; then
 296     pstruct lcrecord_list
 297   elif lrecord_type_p lstream; then
 298     pstruct lstream
 299   elif lrecord_type_p marker; then
 300     pstruct Lisp_Marker
 301   elif lrecord_type_p opaque; then
 302     pstruct Lisp_Opaque
 303   elif lrecord_type_p opaque_list; then
 304     pstruct Lisp_Opaque_List
 305   elif lrecord_type_p popup_data; then
 306     pstruct popup_data
 307   elif lrecord_type_p process; then
 308     pstruct Lisp_Process
 309   elif lrecord_type_p range_table; then
 310     pstruct Lisp_Range_Table
 311   elif lrecord_type_p specifier; then
 312     pstruct Lisp_Specifier
 313   elif lrecord_type_p subr; then
 314     pstruct Lisp_Subr
 315   elif lrecord_type_p symbol_value_buffer_local; then
 316     pstruct symbol_value_buffer_local
 317   elif lrecord_type_p symbol_value_forward; then
 318     pstruct symbol_value_forward
 319   elif lrecord_type_p symbol_value_lisp_magic; then
 320     pstruct symbol_value_lisp_magic
 321   elif lrecord_type_p symbol_value_varalias; then
 322     pstruct symbol_value_varalias
 323   elif lrecord_type_p toolbar_button; then
 324     pstruct toolbar_button
 325   elif lrecord_type_p tooltalk_message; then
 326     pstruct Lisp_Tooltalk_Message
 327   elif lrecord_type_p tooltalk_pattern; then
 328     pstruct Lisp_Tooltalk_Pattern
 329   elif lrecord_type_p weak_list; then
 330     pstruct weak_list
 331   elif lrecord_type_p window; then
 332     pstruct window
 333   elif lrecord_type_p window_configuration; then
 334     pstruct window_config
 335   elif test "$type" = "null_pointer"; then
 336     echo "Lisp Object is a null pointer!!"
 337   else
 338     echo "Unknown Lisp Object type"
 339     print $1
 340   fi
 341 }
 342
 343 function pproc {
 344   print *(`process.c`struct Lisp_Process*)$1 ;
 345   ldp "(`process.c`struct Lisp_Process*)$1->name" ;
 346   ldp "(`process.c`struct Lisp_Process*)$1->command" ;
 347 }
 348
 349 dbxenv suppress_startup_message 4.0
 350 dbxenv mt_watchpoints on
 351
 352 function dp_core {
 353   print ((struct x_frame *)(((struct frame*)(Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget->core
 354 }
 355
 356 # Barf!
 357 function print_shell {
 358   print *(`frame-x.c`TopLevelShellRec*) (((struct `frame-x.c`x_frame*) (((struct `frame-x.c`frame*) (Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget)
 359 }
 360
 361 # -------------------------------------------------------------
 362 # functions to test the debugging support itself.
 363 # If you change this file, make sure the following still work...
 364 # -------------------------------------------------------------
 365 function test_xtype {
 366   function doit { echo -n "$1: "; xtype "$1"; }
 367   test_various_objects
 368 }
 369
 370 function test_pobj {
 371   function doit { echo '==============================='; echo -n "$1: "; pobj "$1"; }
 372   test_various_objects
 373 }
 374
 375 function test_various_objects {
 376   doit Vemacs_major_version
 377   doit Vhelp_char
 378   doit Qnil
 379   doit Qunbound
 380   doit Vobarray
 381   doit Vall_weak_lists
 382   doit Vxemacs_codename
 383 }