diff src/dbxrc @ 371:cc15677e0335 r21-2b1

Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents fbbf69b4e8a7
children 8626e4521993
line wrap: on
line diff
--- a/src/dbxrc	Mon Aug 13 11:01:58 2007 +0200
+++ b/src/dbxrc	Mon Aug 13 11:03:08 2007 +0200
@@ -23,7 +23,7 @@
 # You can use this file to debug XEmacs using Sun WorkShop's dbx.
 # Add the contents of this file to $HOME/.dbxrc or
 # Source the contents of this file with something like:
-# if test -r ./dbxrc; then . ./dbxrc; fi
+# test -r ./dbxrc && . ./dbxrc
 
 # Some functions defined here require a running process, but most
 # don't.  Considerable effort has been expended to this end.
@@ -58,23 +58,10 @@
 
 # A bug in dbx prevents string variables from having values beginning with `-'!!
 function XEmacsInit {
-  function ToInt { eval "$1=\$[(int) $1]"; }
-  ToInt dbg_USE_MINIMAL_TAGBITS
-  ToInt dbg_USE_UNION_TYPE
-  ToInt dbg_USE_INDEXED_LRECORD_IMPLEMENTATION
-  ToInt Lisp_Type_Int
-  ToInt Lisp_Type_Char
-  ToInt Lisp_Type_Cons
-  ToInt Lisp_Type_String
-  ToInt Lisp_Type_Vector
-  ToInt Lisp_Type_Symbol
-  ToInt Lisp_Type_Record
-  ToInt dbg_valbits
-  ToInt dbg_gctypebits
-  function ToLong { eval "$1=\$[(unsigned long) $1]"; }
-  ToLong dbg_valmask
-  ToLong dbg_typemask
+  eval $(echo $(whatis -t `alloc.c`dbg_constants) | \
+    perl -e 'print "@{[map {s/=(-\d+)/sprintf(q[=0x%x],$1)/oge; /\w+=[0-9a-fx]+/og} <>]}\n"')
   xemacs_initted=yes
+  #printvar dbg_valbits dbg_valmask
 }
 
 function printvar {
@@ -89,48 +76,31 @@
 
 # Various dbx bugs cause ugliness in following code
 function decode_object {
-  if test -z "$xemacs_initted"; then XEmacsInit; fi;
-  if test $dbg_USE_UNION_TYPE = 1; then
-    # Repeat after me... dbx sux, dbx sux, dbx sux...
-    # Allow both `pobj Qnil' and `pobj 0x82746834' to work
-    case $(whatis $1) in
-      *Lisp_Object*) obj="$[(unsigned long)(($1).i)]";;
-      *) obj="$[(unsigned long)($1)]";;
-    esac
-  else
-    obj="$[(unsigned long)($1)]";
-  fi
+  test -z "$xemacs_initted" && XEmacsInit
+  obj=$[*(void**)(&$1)]
+  test "$obj" = "(nil)" && obj="0x0"
   if test $dbg_USE_MINIMAL_TAGBITS = 1; then
     if test $[(int)($obj & 1)] = 1; then
       # It's an int
       val=$[(long)(((unsigned long long)$obj) >> 1)]
-      type=$Lisp_Type_Int
+      type=$dbg_Lisp_Type_Int
     else
       type=$[(int)(((void*)$obj) & $dbg_typemask)]
-      if test $type = $Lisp_Type_Char; then
+      if test $type = $dbg_Lisp_Type_Char; then
         val=$[(void*)(long)(((unsigned long long)($obj & $dbg_valmask)) >> $dbg_gctypebits)]
       else
         # It's a record pointer
         val=$[(void*)$obj]
-        if test "$val" = "(nil)"; then type=null_pointer; fi
       fi
     fi
   else
     # not dbg_USE_MINIMAL_TAGBITS
+    val=$[(void*)($obj & $dbg_valmask)]
+    test "$val" = "(nil)" && val="0x0"
     type=$[(int)(((unsigned long long)($obj & $dbg_typemask)) >> ($dbg_valbits + 1))]
-    if test "$type" = $Lisp_Type_Int; then
-      val=$[(int)($obj & $dbg_valmask)]
-    elif test "$type" = $Lisp_Type_Char; then
-      val=$[(int)($obj & $dbg_valmask)]
-    else
-      val=$[(void*)($obj & $dbg_valmask)]
-      if test "$val" = "(nil)"; then type=null_pointer; fi
-    fi
-    #val=$[(void*)($obj & $dbg_valmask)]
-    #printvar val type obj
   fi
 
-  if test $type = $Lisp_Type_Record; then
+  if test $type = $dbg_Lisp_Type_Record; then
     typeset lheader="((struct lrecord_header *) $val)"
     if test $dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1; then
       imp=$[(void*)(lrecord_implementations_table[$lheader->type])]
@@ -140,7 +110,7 @@
   else
     imp="0xdeadbeef"
   fi
-  # printvar obj val type imp
+  #printvar obj val type imp
 }
 
 function xint {
@@ -150,28 +120,17 @@
 
 function xtype {
   decode_object "$*"
-  if   test $type = $Lisp_Type_Int;    then echo "int"
-  elif test $type = $Lisp_Type_Char;   then echo "char"
-  elif test $type = $Lisp_Type_Symbol; then echo "symbol"
-  elif test $type = $Lisp_Type_String; then echo "string"
-  elif test $type = $Lisp_Type_Vector; then echo "vector"
-  elif test $type = $Lisp_Type_Cons;   then echo "cons"
-  elif test $type = null_pointer;      then echo "null_pointer"
+  if   test $type = $dbg_Lisp_Type_Int;    then echo "int"
+  elif test $type = $dbg_Lisp_Type_Char;   then echo "char"
+  elif test $type = $dbg_Lisp_Type_Symbol; then echo "symbol"
+  elif test $type = $dbg_Lisp_Type_String; then echo "string"
+  elif test $type = $dbg_Lisp_Type_Vector; then echo "vector"
+  elif test $type = $dbg_Lisp_Type_Cons;   then echo "cons"
   else
     echo "record type with name: $[((struct lrecord_implementation *)$imp)->name]"
   fi
 }
 
-function lisp-shadows {
-  run -batch -vanilla -f list-load-path-shadows
-}
-
-function environment-to-run-temacs {
-  unset EMACSLOADPATH
-  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
-  export EMACSBOOTSTRAPMODULEPATH=../modules/:..
-}
-
 document run-temacs << 'end'
 Usage: run-temacs
 Run temacs interactively, like xemacs.
@@ -180,7 +139,8 @@
 end
 
 function run-temacs {
-  environment-to-run-temacs
+  unset EMACSLOADPATH
+  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
   run -batch -l ../lisp/loadup.el run-temacs -q
 }
 
@@ -192,13 +152,15 @@
 end
 
 function update-elc {
-  environment-to-run-temacs
+  unset EMACSLOADPATH
+  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
   run -batch -l ../lisp/update-elc.el
 }
 
 
 function dump-temacs {
-  environment-to-run-temacs
+  unset EMACSLOADPATH
+  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
   run -batch -l ../lisp/loadup.el dump
 }
 
@@ -226,22 +188,22 @@
 
 function pobj {
   decode_object $1
-  if test $type = $Lisp_Type_Int; then
+  if test $type = $dbg_Lisp_Type_Int; then
     print -f"Integer: %d" $val
-  elif test $type = $Lisp_Type_Char; then
-    if test $[$val > 32 && $val < 128] = 1; then
+  elif test $type = $dbg_Lisp_Type_Char; then
+    if $val < 128; then
       print -f"Char: %c" $val
     else
       print -f"Char: %d" $val
     fi
-  elif test $type = $Lisp_Type_String || lrecord_type_p string; then
+  elif test $type = $dbg_Lisp_Type_String || lrecord_type_p string; then
     pstruct Lisp_String
-  elif test $type = $Lisp_Type_Cons   || lrecord_type_p cons; then
+  elif test $type = $dbg_Lisp_Type_Cons   || lrecord_type_p cons; then
     pstruct Lisp_Cons
-  elif test $type = $Lisp_Type_Symbol || lrecord_type_p symbol; then
+  elif test $type = $dbg_Lisp_Type_Symbol || lrecord_type_p symbol; then
     pstruct Lisp_Symbol
     echo "Symbol name: $[(char *)($xstruct->name->_data)]"
-  elif test $type = $Lisp_Type_Vector || lrecord_type_p vector; then
+  elif test $type = $dbg_Lisp_Type_Vector || lrecord_type_p vector; then
     pstruct Lisp_Vector
     echo "Vector of length $[$xstruct->size]"
   elif lrecord_type_p bit_vector; then
@@ -265,7 +227,7 @@
   elif lrecord_type_p console; then
     pstruct console
   elif lrecord_type_p database; then
-    pstruct Lisp_Database
+    pstruct database
   elif lrecord_type_p device; then
     pstruct device
   elif lrecord_type_p event; then
@@ -287,11 +249,11 @@
   elif lrecord_type_p glyph; then
     pstruct Lisp_Glyph
   elif lrecord_type_p hashtable; then
-    pstruct Lisp_Hash_Table
+    pstruct hashtable
   elif lrecord_type_p image_instance; then
     pstruct Lisp_Image_Instance
   elif lrecord_type_p keymap; then
-    pstruct Lisp_Keymap
+    pstruct keymap
   elif lrecord_type_p lcrecord_list; then
     pstruct lcrecord_list
   elif lrecord_type_p lstream; then
@@ -332,8 +294,6 @@
     pstruct window
   elif lrecord_type_p window_configuration; then
     pstruct window_config
-  elif test "$type" = "null_pointer"; then
-    echo "Lisp Object is a null pointer!!"
   else
     echo "Unknown Lisp Object type"
     print $1
@@ -347,7 +307,6 @@
 }
 
 dbxenv suppress_startup_message 4.0
-dbxenv mt_watchpoints on
 
 function dp_core {
   print ((struct x_frame *)(((struct frame*)(Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget->core
@@ -357,27 +316,3 @@
 function print_shell {
   print *(`frame-x.c`TopLevelShellRec*) (((struct `frame-x.c`x_frame*) (((struct `frame-x.c`frame*) (Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget)
 }
-
-# -------------------------------------------------------------
-# functions to test the debugging support itself.
-# If you change this file, make sure the following still work...
-# -------------------------------------------------------------
-function test_xtype {
-  function doit { echo -n "$1: "; xtype "$1"; }
-  test_various_objects
-}
-
-function test_pobj {
-  function doit { echo '==============================='; echo -n "$1: "; pobj "$1"; }
-  test_various_objects
-}
-
-function test_various_objects {
-  doit Vemacs_major_version
-  doit Vhelp_char
-  doit Qnil
-  doit Qunbound
-  doit Vobarray
-  doit Vall_weak_lists
-  doit Vxemacs_codename
-}