XEmacs 21.2.13

diff --git a/src/dbxrc b/src/dbxrc
index bb2b78b..a757115 100644 (file)
--- a/src/dbxrc
+++ b/src/dbxrc
@@ -58,10 +58,23 @@ function ldp {
 
 # A bug in dbx prevents string variables from having values beginning with `-'!!
 function XEmacsInit {
-  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"')
+  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
   xemacs_initted=yes
-  #printvar dbg_valbits dbg_valmask
 }
 
 function printvar {
@@ -91,10 +104,10 @@ function decode_object {
     if test $[(int)($obj & 1)] = 1; then
       # It's an int
       val=$[(long)(((unsigned long long)$obj) >> 1)]
-      type=$dbg_Lisp_Type_Int
+      type=$Lisp_Type_Int
     else
       type=$[(int)(((void*)$obj) & $dbg_typemask)]
-      if test $type = $dbg_Lisp_Type_Char; then
+      if test $type = $Lisp_Type_Char; then
         val=$[(void*)(long)(((unsigned long long)($obj & $dbg_valmask)) >> $dbg_gctypebits)]
       else
         # It's a record pointer
@@ -105,9 +118,9 @@ function decode_object {
   else
     # not dbg_USE_MINIMAL_TAGBITS
     type=$[(int)(((unsigned long long)($obj & $dbg_typemask)) >> ($dbg_valbits + 1))]
-    if test "$[$type == Lisp_Type_Int]" = 1; then
+    if test "$type" = $Lisp_Type_Int; then
       val=$[(int)($obj & $dbg_valmask)]
-    elif test "$[$type == Lisp_Type_Char]" = 1; then
+    elif test "$type" = $Lisp_Type_Char; then
       val=$[(int)($obj & $dbg_valmask)]
     else
       val=$[(void*)($obj & $dbg_valmask)]
@@ -117,7 +130,7 @@ function decode_object {
     #printvar val type obj
   fi
 
-  if test $type = $dbg_Lisp_Type_Record; then
+  if test $type = $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])]
@@ -127,7 +140,7 @@ function decode_object {
   else
     imp="0xdeadbeef"
   fi
-  #printvar obj val type imp
+  # printvar obj val type imp
 }
 
 function xint {
@@ -137,18 +150,28 @@ function xint {
 
 function xtype {
   decode_object "$*"
-  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"
-  elif test $type = null_pointer;          then echo "$type"
+  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"
   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.
@@ -157,8 +180,7 @@ or when temacs builds successfully, but xemacs does not.
 end
 
 function run-temacs {
-  unset EMACSLOADPATH
-  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
+  environment-to-run-temacs
   run -batch -l ../lisp/loadup.el run-temacs -q
 }
 
@@ -170,15 +192,13 @@ Use this when temacs builds successfully, but xemacs does not.
 end
 
 function update-elc {
-  unset EMACSLOADPATH
-  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
+  environment-to-run-temacs
   run -batch -l ../lisp/update-elc.el
 }
 
 
 function dump-temacs {
-  unset EMACSLOADPATH
-  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
+  environment-to-run-temacs
   run -batch -l ../lisp/loadup.el dump
 }
 
@@ -206,22 +226,22 @@ end
 
 function pobj {
   decode_object $1
-  if test $type = $dbg_Lisp_Type_Int; then
+  if test $type = $Lisp_Type_Int; then
     print -f"Integer: %d" $val
-  elif test $type = $dbg_Lisp_Type_Char; then
-    if $val < 128; then
+  elif test $type = $Lisp_Type_Char; then
+    if test $[$val > 32 && $val < 128] = 1; then
       print -f"Char: %c" $val
     else
       print -f"Char: %d" $val
     fi
-  elif test $type = $dbg_Lisp_Type_String || lrecord_type_p string; then
+  elif test $type = $Lisp_Type_String || lrecord_type_p string; then
     pstruct Lisp_String
-  elif test $type = $dbg_Lisp_Type_Cons   || lrecord_type_p cons; then
+  elif test $type = $Lisp_Type_Cons   || lrecord_type_p cons; then
     pstruct Lisp_Cons
-  elif test $type = $dbg_Lisp_Type_Symbol || lrecord_type_p symbol; then
+  elif test $type = $Lisp_Type_Symbol || lrecord_type_p symbol; then
     pstruct Lisp_Symbol
-    echo "Symbol name: $[(char *)($xstruct->name->_data)]"
-  elif test $type = $dbg_Lisp_Type_Vector || lrecord_type_p vector; then
+    echo "Symbol name: $[(char *)($xstruct->name->data)]"
+  elif test $type = $Lisp_Type_Vector || lrecord_type_p vector; then
     pstruct Lisp_Vector
     echo "Vector of length $[$xstruct->size]"
   elif lrecord_type_p bit_vector; then
@@ -337,3 +357,27 @@ function dp_core {
 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
+}

diff --git a/src/gdbinit b/src/gdbinit
index 60cadae..0259597 100644 (file)
--- a/src/gdbinit
+++ b/src/gdbinit
@@ -53,10 +53,10 @@ define decode_object
     if $obj & 1
     # It's an int
       set $val = $obj >> 1
-      set $type = dbg_Lisp_Type_Int
+      set $type = Lisp_Type_Int
     else
       set $type = $obj & dbg_typemask
-      if $type == dbg_Lisp_Type_Char
+      if $type == Lisp_Type_Char
         set $val = ($obj & dbg_valmask) >> dbg_gctypebits
       else
         # It's a record pointer
@@ -69,7 +69,7 @@ define decode_object
     set $type = ($obj & dbg_typemask) >> (dbg_valbits + 1)
   end
 
-  if $type == dbg_Lisp_Type_Record
+  if $type == Lisp_Type_Record
     set $lheader = (struct lrecord_header *) $val
     if dbg_USE_INDEXED_LRECORD_IMPLEMENTATION
       set $imp = lrecord_implementations_table[$lheader->type]
@@ -94,22 +94,22 @@ end
 
 define xtype
   decode_object $arg0
-  if $type == dbg_Lisp_Type_Int
+  if $type == Lisp_Type_Int
     echo int\n
   else
-  if $type == dbg_Lisp_Type_Char
+  if $type == Lisp_Type_Char
     echo char\n
   else
-  if $type == dbg_Lisp_Type_Symbol
+  if $type == Lisp_Type_Symbol
     echo symbol\n
   else
-  if $type == dbg_Lisp_Type_String
+  if $type == Lisp_Type_String
     echo string\n
   else
-  if $type == dbg_Lisp_Type_Vector
+  if $type == Lisp_Type_Vector
     echo vector\n
   else
-  if $type == dbg_Lisp_Type_Cons
+  if $type == Lisp_Type_Cons
     echo cons\n
   else
     printf "record type: %s\n", $imp->name
@@ -133,8 +133,8 @@ end
 
 define environment-to-run-temacs
   unset env EMACSLOADPATH
-  set env EMACSBOOTSTRAPLOADPATH   = ../lisp/:..
-  set env EMACSBOOTSTRAPMODULEPATH = ../lisp/
+  set env EMACSBOOTSTRAPLOADPATH=../lisp/:..
+  set env EMACSBOOTSTRAPMODULEPATH=../modules/:..
 end
 
 define run-temacs
@@ -197,6 +197,22 @@ Print the current Lisp stack trace.
 Requires a running xemacs process.
 end
 
+
+define leval
+ldp Feval(Fcar(Fread_from_string(build_string($arg0),Qnil,Qnil)))
+end
+
+document leval
+Usage: leval "SEXP"
+Eval a lisp expression.
+Requires a running xemacs process.
+
+Example:
+(gdb) leval "(+ 1 2)"
+Lisp ==> 3
+end
+
+
 define wtype
 print $arg0->core.widget_class->core_class.class_name
 end
@@ -215,27 +231,27 @@ end
 
 define pobj
   decode_object $arg0
-  if $type == dbg_Lisp_Type_Int
+  if $type == Lisp_Type_Int
     printf "Integer: %d\n", $val
   else
-  if $type == dbg_Lisp_Type_Char
-    if $val < 128
+  if $type == Lisp_Type_Char
+    if $val > 32 && $val < 128
       printf "Char: %c\n", $val
     else
       printf "Char: %d\n", $val
     end
   else
-  if $type == dbg_Lisp_Type_String || $imp == lrecord_string
+  if $type == Lisp_Type_String || $imp == lrecord_string
     pstruct Lisp_String
   else
-  if $type == dbg_Lisp_Type_Cons   || $imp == lrecord_cons
+  if $type == Lisp_Type_Cons   || $imp == lrecord_cons
     pstruct Lisp_Cons
   else
-  if $type == dbg_Lisp_Type_Symbol || $imp == lrecord_symbol
+  if $type == Lisp_Type_Symbol || $imp == lrecord_symbol
     pstruct Lisp_Symbol
     printf "Symbol name: %s\n", $xstruct->name->data
   else
-  if $type == dbg_Lisp_Type_Vector || $imp == lrecord_vector
+  if $type == Lisp_Type_Vector || $imp == lrecord_vector
     pstruct Lisp_Vector
     printf "Vector of length %d\n", $xstruct->size
     #print *($xstruct->data) @ $xstruct->size
@@ -433,3 +449,42 @@ document pobj
 Usage: pobj lisp_object
 Print the internal C structure of a underlying Lisp Object.
 end
+
+# -------------------------------------------------------------
+# functions to test the debugging support itself.
+# If you change this file, make sure the following still work...
+# -------------------------------------------------------------
+define test_xtype
+  printf "Vemacs_major_version: "
+  xtype Vemacs_major_version
+  printf "Vhelp_char: "
+  xtype Vhelp_char
+  printf "Qnil: "
+  xtype Qnil
+  printf "Qunbound: "
+  xtype Qunbound
+  printf "Vobarray: "
+  xtype Vobarray
+  printf "Vall_weak_lists: "
+  xtype Vall_weak_lists
+  printf "Vxemacs_codename: "
+  xtype Vxemacs_codename
+end
+
+define test_pobj
+  printf "Vemacs_major_version: "
+  pobj Vemacs_major_version
+  printf "Vhelp_char: "
+  pobj Vhelp_char
+  printf "Qnil: "
+  pobj Qnil
+  printf "Qunbound: "
+  pobj Qunbound
+  printf "Vobarray: "
+  pobj Vobarray
+  printf "Vall_weak_lists: "
+  pobj Vall_weak_lists
+  printf "Vxemacs_codename: "
+  pobj Vxemacs_codename
+end
+