# -*- 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 {
  unset EMACSLOADPATH
  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
  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 {
  unset EMACSLOADPATH
  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
  run -batch -l ../lisp/update-elc.el
}


function dump-temacs {
  unset EMACSLOADPATH
  export EMACSBOOTSTRAPLOADPATH=../lisp/:..
  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 = $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 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)
}