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_UNION_TYPE
  63   ToInt Lisp_Type_Int
  64   ToInt Lisp_Type_Char
  65   ToInt Lisp_Type_Cons
  66   ToInt Lisp_Type_String
  67   ToInt Lisp_Type_Vector
  68   ToInt Lisp_Type_Symbol
  69   ToInt Lisp_Type_Record
  70   ToInt dbg_valbits
  71   ToInt dbg_gctypebits
  72   function ToLong { eval "$1=\$[(unsigned long) $1]"; }
  73   ToLong dbg_valmask
  74   ToLong dbg_typemask
  75   xemacs_initted=yes
  76 }
  77
  78 function printvar {
  79   for i in $*; do eval "echo $i=\$$i"; done
  80 }
  81
  82 document decode_object << 'end'
  83 Usage: decode_object lisp_object
  84 Extract implementation information from a Lisp Object.
  85 Defines variables $val, $type and $imp.
  86 end
  87
  88 # Various dbx bugs cause ugliness in following code
  89 function decode_object {
  90   if test -z "$xemacs_initted"; then XEmacsInit; fi;
  91   if test $dbg_USE_UNION_TYPE = 1; then
  92     # Repeat after me... dbx sux, dbx sux, dbx sux...
  93     # Allow both `pobj Qnil' and `pobj 0x82746834' to work
  94     case $(whatis $1) in
  95       *Lisp_Object*) obj="$[(unsigned long)(($1).i)]";;
  96       *) obj="$[(unsigned long)($1)]";;
  97     esac
  98   else
  99     obj="$[(unsigned long)($1)]";
 100   fi
 101   if test $[(int)($obj & 1)] = 1; then
 102     # It's an int
 103     val=$[(long)(((unsigned long long)$obj) >> 1)]
 104     type=$Lisp_Type_Int
 105   else
 106     type=$[(int)(((void*)$obj) & $dbg_typemask)]
 107     if test $type = $Lisp_Type_Char; then
 108       val=$[(void*)(long)(((unsigned long long)($obj & $dbg_valmask)) >> $dbg_gctypebits)]
 109     else
 110       # It's a record pointer
 111       val=$[(void*)$obj]
 112       if test "$val" = "(nil)"; then type=null_pointer; fi
 113     fi
 114   fi
 115
 116   if test $type = $Lisp_Type_Record; then
 117     typeset lheader="((struct lrecord_header *) $val)"
 118     imp=$[(void*)(lrecord_implementations_table[$lheader->type])]
 119   else
 120     imp="0xdeadbeef"
 121   fi
 122   # printvar obj val type imp
 123 }
 124
 125 function xint {
 126   decode_object "$*"
 127   print (long) ($val)
 128 }
 129
 130 function xtype {
 131   decode_object "$*"
 132   if   test $type = $Lisp_Type_Int;    then echo "int"
 133   elif test $type = $Lisp_Type_Char;   then echo "char"
 134   elif test $type = $Lisp_Type_Symbol; then echo "symbol"
 135   elif test $type = $Lisp_Type_String; then echo "string"
 136   elif test $type = $Lisp_Type_Vector; then echo "vector"
 137   elif test $type = $Lisp_Type_Cons;   then echo "cons"
 138   elif test $type = null_pointer;      then echo "null_pointer"
 139   else
 140     echo "record type with name: $[((struct lrecord_implementation *)$imp)->name]"
 141   fi
 142 }
 143
 144 function lisp-shadows {
 145   run -batch -vanilla -f list-load-path-shadows
 146 }
 147
 148 function environment-to-run-temacs {
 149   unset EMACSLOADPATH
 150   export EMACSBOOTSTRAPLOADPATH=../lisp/:..
 151   export EMACSBOOTSTRAPMODULEPATH=../modules/:..
 152 }
 153
 154 document run-temacs << 'end'
 155 Usage: run-temacs
 156 Run temacs interactively, like xemacs.
 157 Use this with debugging tools (like purify) that cannot deal with dumping,
 158 or when temacs builds successfully, but xemacs does not.
 159 end
 160
 161 function run-temacs {
 162   environment-to-run-temacs
 163   run -batch -l ../lisp/loadup.el run-temacs -q
 164 }
 165
 166 document update-elc << 'end'
 167 Usage: update-elc
 168 Run the core lisp byte compilation part of the build procedure.
 169 Use when debugging temacs, not xemacs!
 170 Use this when temacs builds successfully, but xemacs does not.
 171 end
 172
 173 function update-elc {
 174   environment-to-run-temacs
 175   run -batch -l ../lisp/update-elc.el
 176 }
 177
 178
 179 function dump-temacs {
 180   environment-to-run-temacs
 181   run -batch -l ../lisp/loadup.el dump
 182 }
 183
 184 document dump-temacs << 'end'
 185 Usage: dump-temacs
 186 Run the dumping part of the build procedure.
 187 Use when debugging temacs, not xemacs!
 188 Use this when temacs builds successfully, but xemacs does not.
 189 end
 190
 191 function pstruct {
 192   xstruct="((struct $1 *) $val)"
 193   print $xstruct
 194   print *$xstruct
 195 }
 196
 197 function lrecord_type_p {
 198   if eval test -z \"\$lrecord_$1\" && test $imp = $[(void*)(&lrecord_$1)]; then return 0; else return 1; fi
 199 }
 200
 201 document pobj << 'end'
 202 Usage: pobj lisp_object
 203 Print the internal C structure of a underlying Lisp Object.
 204 end
 205
 206 function pobj {
 207   decode_object $1
 208   if test $type = $Lisp_Type_Int; then
 209     print -f"Integer: %d" $val
 210   elif test $type = $Lisp_Type_Char; then
 211     if test $[$val > 32 && $val < 128] = 1; then
 212       print -f"Char: %c" $val
 213     else
 214       print -f"Char: %d" $val
 215     fi
 216   elif test $type = $Lisp_Type_String || lrecord_type_p string; then
 217     pstruct Lisp_String
 218   elif test $type = $Lisp_Type_Cons   || lrecord_type_p cons; then
 219     pstruct Lisp_Cons
 220   elif test $type = $Lisp_Type_Symbol || lrecord_type_p symbol; then
 221     pstruct Lisp_Symbol
 222     echo "Symbol name: $[(char *)($xstruct->name->data)]"
 223   elif test $type = $Lisp_Type_Vector || lrecord_type_p vector; then
 224     pstruct Lisp_Vector
 225     echo "Vector of length $[$xstruct->size]"
 226   elif lrecord_type_p bit_vector; then
 227     pstruct Lisp_Bit_Vector
 228   elif lrecord_type_p buffer; then
 229     pstruct buffer
 230   elif lrecord_type_p char_table; then
 231     pstruct Lisp_Char_Table
 232   elif lrecord_type_p char_table_entry; then
 233     pstruct Lisp_Char_Table_Entry
 234   elif lrecord_type_p charset; then
 235     pstruct Lisp_Charset
 236   elif lrecord_type_p coding_system; then
 237     pstruct Lisp_Coding_System
 238   elif lrecord_type_p color_instance; then
 239     pstruct Lisp_Color_Instance
 240   elif lrecord_type_p command_builder; then
 241     pstruct command_builder
 242   elif lrecord_type_p compiled_function; then
 243     pstruct Lisp_Compiled_Function
 244   elif lrecord_type_p console; then
 245     pstruct console
 246   elif lrecord_type_p database; then
 247     pstruct Lisp_Database
 248   elif lrecord_type_p device; then
 249     pstruct device
 250   elif lrecord_type_p event; then
 251     pstruct Lisp_Event
 252   elif lrecord_type_p extent; then
 253     pstruct extent
 254   elif lrecord_type_p extent_auxiliary; then
 255     pstruct extent_auxiliary
 256   elif lrecord_type_p extent_info; then
 257     pstruct extent_info
 258   elif lrecord_type_p face; then
 259     pstruct Lisp_Face
 260   elif lrecord_type_p float; then
 261     pstruct Lisp_Float
 262   elif lrecord_type_p font_instance; then
 263     pstruct Lisp_Font_Instance
 264   elif lrecord_type_p frame; then
 265     pstruct frame
 266   elif lrecord_type_p glyph; then
 267     pstruct Lisp_Glyph
 268   elif lrecord_type_p hash_table; then
 269     pstruct Lisp_Hash_Table
 270   elif lrecord_type_p image_instance; then
 271     pstruct Lisp_Image_Instance
 272   elif lrecord_type_p keymap; then
 273     pstruct Lisp_Keymap
 274   elif lrecord_type_p lcrecord_list; then
 275     pstruct lcrecord_list
 276   elif lrecord_type_p lstream; then
 277     pstruct lstream
 278   elif lrecord_type_p marker; then
 279     pstruct Lisp_Marker
 280   elif lrecord_type_p opaque; then
 281     pstruct Lisp_Opaque
 282   elif lrecord_type_p opaque_list; then
 283     pstruct Lisp_Opaque_List
 284   elif lrecord_type_p popup_data; then
 285     pstruct popup_data
 286   elif lrecord_type_p process; then
 287     pstruct Lisp_Process
 288   elif lrecord_type_p range_table; then
 289     pstruct Lisp_Range_Table
 290   elif lrecord_type_p specifier; then
 291     pstruct Lisp_Specifier
 292   elif lrecord_type_p subr; then
 293     pstruct Lisp_Subr
 294   elif lrecord_type_p symbol_value_buffer_local; then
 295     pstruct symbol_value_buffer_local
 296   elif lrecord_type_p symbol_value_forward; then
 297     pstruct symbol_value_forward
 298   elif lrecord_type_p symbol_value_lisp_magic; then
 299     pstruct symbol_value_lisp_magic
 300   elif lrecord_type_p symbol_value_varalias; then
 301     pstruct symbol_value_varalias
 302   elif lrecord_type_p toolbar_button; then
 303     pstruct toolbar_button
 304   elif lrecord_type_p tooltalk_message; then
 305     pstruct Lisp_Tooltalk_Message
 306   elif lrecord_type_p tooltalk_pattern; then
 307     pstruct Lisp_Tooltalk_Pattern
 308   elif lrecord_type_p weak_list; then
 309     pstruct weak_list
 310   elif lrecord_type_p window; then
 311     pstruct window
 312   elif lrecord_type_p window_configuration; then
 313     pstruct window_config
 314   elif test "$type" = "null_pointer"; then
 315     echo "Lisp Object is a null pointer!!"
 316   else
 317     echo "Unknown Lisp Object type"
 318     print $1
 319   fi
 320 }
 321
 322 function pproc {
 323   print *(`process.c`struct Lisp_Process*)$1 ;
 324   ldp "(`process.c`struct Lisp_Process*)$1->name" ;
 325   ldp "(`process.c`struct Lisp_Process*)$1->command" ;
 326 }
 327
 328 dbxenv suppress_startup_message 4.0
 329 dbxenv mt_watchpoints on
 330
 331 function dp_core {
 332   print ((struct x_frame *)(((struct frame*)(Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget->core
 333 }
 334
 335 # Barf!
 336 function print_shell {
 337   print *(`frame-x.c`TopLevelShellRec*) (((struct `frame-x.c`x_frame*) (((struct `frame-x.c`frame*) (Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget)
 338 }
 339
 340 # -------------------------------------------------------------
 341 # functions to test the debugging support itself.
 342 # If you change this file, make sure the following still work...
 343 # -------------------------------------------------------------
 344 function test_xtype {
 345   function doit { echo -n "$1: "; xtype "$1"; }
 346   test_various_objects
 347 }
 348
 349 function test_pobj {
 350   function doit { echo '==============================='; echo -n "$1: "; pobj "$1"; }
 351   test_various_objects
 352 }
 353
 354 function test_various_objects {
 355   doit Vemacs_major_version
 356   doit Vhelp_char
 357   doit Qnil
 358   doit Qunbound
 359   doit Vobarray
 360   doit Vall_weak_lists
 361   doit Vxemacs_codename
 362 }