# -*- 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:
# test -r ./dbxrc && . ./dbxrc

# 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 {
  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 {
  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 {
  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=$dbg_Lisp_Type_Int
    else
      type=$[(int)(((void*)$obj) & $dbg_typemask)]
      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]
      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))]
  fi

  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])]
    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 = $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
}

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 {
  run -batch -l loadup.el run-temacs -q
}

document update-elc << 'end'
Usage: update-elc
Run the elc 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 {
  export EMACSLOADPATH=../lisp/
  run -batch -l update-elc.el
}

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 = $dbg_Lisp_Type_Int; then
    print -f"Integer: %d" $val
  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 = $dbg_Lisp_Type_String || lrecord_type_p string; then
    pstruct Lisp_String
  elif test $type = $dbg_Lisp_Type_Cons   || lrecord_type_p cons; then
    pstruct Lisp_Cons
  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 = $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
    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 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 hashtable; then
    pstruct hashtable
  elif lrecord_type_p image_instance; then
    pstruct Lisp_Image_Instance
  elif lrecord_type_p keymap; then
    pstruct 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 toolbar_data; then
    pstruct toolbar_data
  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
  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

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)
}