# -*- ksh -*-
# Copyright (C) 1998 Free Software Foundation, Inc.

# This file is part of XEmacs.

# XEmacs is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version.

# XEmacs is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.

# You should have received a copy of the GNU General Public License
# along with XEmacs; see the file COPYING.  If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.

# Author: Martin Buchholz

# 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

# Some functions defined here require a running process, but most
# don't.  Considerable effort has been expended to this end.

# See also the comments in gdbinit.

# See also the question of the XEmacs FAQ, titled
# "How to Debug an XEmacs problem with a debugger".

ignore POLL
ignore IO

document lbt << 'end'
Usage: lbt
Print the current Lisp stack trace.
Requires a running xemacs process.
end

function lbt {
  call debug_backtrace()
}

document ldp << 'end'
Usage: ldp lisp_object
Print a Lisp Object value using the Lisp printer.
Requires a running xemacs process.
end

function ldp {
  call debug_print ($1);
}

# 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
  xemacs_initted=yes
}

function printvar {
  for i in $*; do eval "echo $i=\$$i"; done
}

document decode_object << 'end'
Usage: decode_object lisp_object
Extract implementation information from a Lisp Object.
Defines variables $val, $type and $imp.
end

# 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
  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
    else
      type=$[(int)(((void*)$obj) & $dbg_typemask)]
      if test $type = $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
    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
    typeset lheader="((struct lrecord_header *) $val)"
    if test $dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1; then
      imp=$[(void*)(lrecord_implementations_table[$lheader->type])]
    else
      imp=$[(void*)($lheader->implementation)]
    fi
  else
    imp="0xdeadbeef"
  fi
  # printvar obj val type imp
}

function xint {
  decode_object "$*"
  print (long) ($val)
}

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"
  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.
Use this with debugging tools (like purify) that cannot deal with dumping,
or when temacs builds successfully, but xemacs does not.
end

function run-temacs {
  environment-to-run-temacs
  run -batch -l ../lisp/loadup.el run-temacs -q
}

document update-elc << 'end'
Usage: update-elc
Run the core lisp byte compilation part of the build procedure.
Use when debugging temacs, not xemacs!
Use this when temacs builds successfully, but xemacs does not.
end

function update-elc {
  environment-to-run-temacs
  run -batch -l ../lisp/update-elc.el
}


function dump-temacs {
  environment-to-run-temacs
  run -batch -l ../lisp/loadup.el dump
}

document dump-temacs << 'end'
Usage: dump-temacs
Run the dumping part of the build procedure.
Use when debugging temacs, not xemacs!
Use this when temacs builds successfully, but xemacs does not.
end

function pstruct {
  xstruct="((struct $1 *) $val)"
  print $xstruct
  print *$xstruct
}

function lrecord_type_p {
  if eval test -z \"\$lrecord_$1\" && test $imp = $[(void*)(&lrecord_$1)]; then return 0; else return 1; fi
}

document pobj << 'end'
Usage: pobj lisp_object
Print the internal C structure of a underlying Lisp Object.
end

function pobj {
  decode_object $1
  if test $type = $Lisp_Type_Int; then
    print -f"Integer: %d" $val
  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 = $Lisp_Type_String || lrecord_type_p string; then
    pstruct Lisp_String
  elif test $type = $Lisp_Type_Cons   || lrecord_type_p cons; then
    pstruct Lisp_Cons
  elif test $type = $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
    pstruct Lisp_Vector
    echo "Vector of length $[$xstruct->size]"
  elif lrecord_type_p bit_vector; then
    pstruct Lisp_Bit_Vector
  elif lrecord_type_p buffer; then
    pstruct buffer
  elif lrecord_type_p char_table; then
    pstruct Lisp_Char_Table
  elif lrecord_type_p char_table_entry; then
    pstruct Lisp_Char_Table_Entry
  elif lrecord_type_p charset; then
    pstruct Lisp_Charset
  elif lrecord_type_p coding_system; then
    pstruct Lisp_Coding_System
  elif lrecord_type_p color_instance; then
    pstruct Lisp_Color_Instance
  elif lrecord_type_p command_builder; then
    pstruct command_builder
  elif lrecord_type_p compiled_function; then
    pstruct Lisp_Compiled_Function
  elif lrecord_type_p console; then
    pstruct console
  elif lrecord_type_p database; then
    pstruct Lisp_Database
  elif lrecord_type_p device; then
    pstruct device
  elif lrecord_type_p event; then
    pstruct Lisp_Event
  elif lrecord_type_p extent; then
    pstruct extent
  elif lrecord_type_p extent_auxiliary; then
    pstruct extent_auxiliary
  elif lrecord_type_p extent_info; then
    pstruct extent_info
  elif lrecord_type_p face; then
    pstruct Lisp_Face
  elif lrecord_type_p float; then
    pstruct Lisp_Float
  elif lrecord_type_p font_instance; then
    pstruct Lisp_Font_Instance
  elif lrecord_type_p frame; then
    pstruct frame
  elif lrecord_type_p glyph; then
    pstruct Lisp_Glyph
  elif lrecord_type_p hash_table; then
    pstruct Lisp_Hash_Table
  elif lrecord_type_p image_instance; then
    pstruct Lisp_Image_Instance
  elif lrecord_type_p keymap; then
    pstruct Lisp_Keymap
  elif lrecord_type_p lcrecord_list; then
    pstruct lcrecord_list
  elif lrecord_type_p lstream; then
    pstruct lstream
  elif lrecord_type_p marker; then
    pstruct Lisp_Marker
  elif lrecord_type_p opaque; then
    pstruct Lisp_Opaque
  elif lrecord_type_p opaque_list; then
    pstruct Lisp_Opaque_List
  elif lrecord_type_p popup_data; then
    pstruct popup_data
  elif lrecord_type_p process; then
    pstruct Lisp_Process
  elif lrecord_type_p range_table; then
    pstruct Lisp_Range_Table
  elif lrecord_type_p specifier; then
    pstruct Lisp_Specifier
  elif lrecord_type_p subr; then
    pstruct Lisp_Subr
  elif lrecord_type_p symbol_value_buffer_local; then
    pstruct symbol_value_buffer_local
  elif lrecord_type_p symbol_value_forward; then
    pstruct symbol_value_forward
  elif lrecord_type_p symbol_value_lisp_magic; then
    pstruct symbol_value_lisp_magic
  elif lrecord_type_p symbol_value_varalias; then
    pstruct symbol_value_varalias
  elif lrecord_type_p toolbar_button; then
    pstruct toolbar_button
  elif lrecord_type_p tooltalk_message; then
    pstruct Lisp_Tooltalk_Message
  elif lrecord_type_p tooltalk_pattern; then
    pstruct Lisp_Tooltalk_Pattern
  elif lrecord_type_p weak_list; then
    pstruct weak_list
  elif lrecord_type_p window; then
    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
  fi
}

function pproc {
  print *(`process.c`struct Lisp_Process*)$1 ;
  ldp "(`process.c`struct Lisp_Process*)$1->name" ;
  ldp "(`process.c`struct Lisp_Process*)$1->command" ;
}

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
}

# Barf!
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
}