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