Mercurial > hg > xemacs-beta

comparison src/dbxrc @ 396:6719134a07c2 r21-2-13

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-13
author cvs
date Mon, 13 Aug 2007 11:12:05 +0200
parents 8626e4521993
children
comparison
equal deleted inserted replaced
395:de2c2a7459d2 396:6719134a07c2
56 call debug_print ($1); 56 call debug_print ($1);
57 } 57 }
58 58
59 # A bug in dbx prevents string variables from having values beginning with `-'!! 59 # A bug in dbx prevents string variables from having values beginning with `-'!!
60 function XEmacsInit { 60 function XEmacsInit {
61 eval $(echo $(whatis -t `alloc.c`dbg_constants) | \ 61 function ToInt { eval "$1=\$[(int) $1]"; }
62 perl -e 'print "@{[map {s/=(-\d+)/sprintf(q[=0x%x],$1)/oge; /\w+=[0-9a-fx]+/og} <>]}\n"') 62 ToInt dbg_USE_MINIMAL_TAGBITS
63 ToInt dbg_USE_UNION_TYPE
64 ToInt dbg_USE_INDEXED_LRECORD_IMPLEMENTATION
65 ToInt Lisp_Type_Int
66 ToInt Lisp_Type_Char
67 ToInt Lisp_Type_Cons
68 ToInt Lisp_Type_String
69 ToInt Lisp_Type_Vector
70 ToInt Lisp_Type_Symbol
71 ToInt Lisp_Type_Record
72 ToInt dbg_valbits
73 ToInt dbg_gctypebits
74 function ToLong { eval "$1=\$[(unsigned long) $1]"; }
75 ToLong dbg_valmask
76 ToLong dbg_typemask
63 xemacs_initted=yes 77 xemacs_initted=yes
64 #printvar dbg_valbits dbg_valmask
65 } 78 }
66 79
67 function printvar { 80 function printvar {
68 for i in $*; do eval "echo $i=\$$i"; done 81 for i in $*; do eval "echo $i=\$$i"; done
69 } 82 }
89 fi 102 fi
90 if test $dbg_USE_MINIMAL_TAGBITS = 1; then 103 if test $dbg_USE_MINIMAL_TAGBITS = 1; then
91 if test $[(int)($obj & 1)] = 1; then 104 if test $[(int)($obj & 1)] = 1; then
92 # It's an int 105 # It's an int
93 val=$[(long)(((unsigned long long)$obj) >> 1)] 106 val=$[(long)(((unsigned long long)$obj) >> 1)]
94 type=$dbg_Lisp_Type_Int 107 type=$Lisp_Type_Int
95 else 108 else
96 type=$[(int)(((void*)$obj) & $dbg_typemask)] 109 type=$[(int)(((void*)$obj) & $dbg_typemask)]
97 if test $type = $dbg_Lisp_Type_Char; then 110 if test $type = $Lisp_Type_Char; then
98 val=$[(void*)(long)(((unsigned long long)($obj & $dbg_valmask)) >> $dbg_gctypebits)] 111 val=$[(void*)(long)(((unsigned long long)($obj & $dbg_valmask)) >> $dbg_gctypebits)]
99 else 112 else
100 # It's a record pointer 113 # It's a record pointer
101 val=$[(void*)$obj] 114 val=$[(void*)$obj]
102 if test "$val" = "(nil)"; then type=null_pointer; fi 115 if test "$val" = "(nil)"; then type=null_pointer; fi
103 fi 116 fi
104 fi 117 fi
105 else 118 else
106 # not dbg_USE_MINIMAL_TAGBITS 119 # not dbg_USE_MINIMAL_TAGBITS
107 type=$[(int)(((unsigned long long)($obj & $dbg_typemask)) >> ($dbg_valbits + 1))] 120 type=$[(int)(((unsigned long long)($obj & $dbg_typemask)) >> ($dbg_valbits + 1))]
108 if test "$[$type == Lisp_Type_Int]" = 1; then 121 if test "$type" = $Lisp_Type_Int; then
109 val=$[(int)($obj & $dbg_valmask)] 122 val=$[(int)($obj & $dbg_valmask)]
110 elif test "$[$type == Lisp_Type_Char]" = 1; then 123 elif test "$type" = $Lisp_Type_Char; then
111 val=$[(int)($obj & $dbg_valmask)] 124 val=$[(int)($obj & $dbg_valmask)]
112 else 125 else
113 val=$[(void*)($obj & $dbg_valmask)] 126 val=$[(void*)($obj & $dbg_valmask)]
114 if test "$val" = "(nil)"; then type=null_pointer; fi 127 if test "$val" = "(nil)"; then type=null_pointer; fi
115 fi 128 fi
116 #val=$[(void*)($obj & $dbg_valmask)] 129 #val=$[(void*)($obj & $dbg_valmask)]
117 #printvar val type obj 130 #printvar val type obj
118 fi 131 fi
119 132
120 if test $type = $dbg_Lisp_Type_Record; then 133 if test $type = $Lisp_Type_Record; then
121 typeset lheader="((struct lrecord_header *) $val)" 134 typeset lheader="((struct lrecord_header *) $val)"
122 if test $dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1; then 135 if test $dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1; then
123 imp=$[(void*)(lrecord_implementations_table[$lheader->type])] 136 imp=$[(void*)(lrecord_implementations_table[$lheader->type])]
124 else 137 else
125 imp=$[(void*)($lheader->implementation)] 138 imp=$[(void*)($lheader->implementation)]
126 fi 139 fi
127 else 140 else
128 imp="0xdeadbeef" 141 imp="0xdeadbeef"
129 fi 142 fi
130 #printvar obj val type imp 143 # printvar obj val type imp
131 } 144 }
132 145
133 function xint { 146 function xint {
134 decode_object "$*" 147 decode_object "$*"
135 print (long) ($val) 148 print (long) ($val)
136 } 149 }
137 150
138 function xtype { 151 function xtype {
139 decode_object "$*" 152 decode_object "$*"
140 if test $type = $dbg_Lisp_Type_Int; then echo "int" 153 if test $type = $Lisp_Type_Int; then echo "int"
141 elif test $type = $dbg_Lisp_Type_Char; then echo "char" 154 elif test $type = $Lisp_Type_Char; then echo "char"
142 elif test $type = $dbg_Lisp_Type_Symbol; then echo "symbol" 155 elif test $type = $Lisp_Type_Symbol; then echo "symbol"
143 elif test $type = $dbg_Lisp_Type_String; then echo "string" 156 elif test $type = $Lisp_Type_String; then echo "string"
144 elif test $type = $dbg_Lisp_Type_Vector; then echo "vector" 157 elif test $type = $Lisp_Type_Vector; then echo "vector"
145 elif test $type = $dbg_Lisp_Type_Cons; then echo "cons" 158 elif test $type = $Lisp_Type_Cons; then echo "cons"
146 elif test $type = null_pointer; then echo "$type" 159 elif test $type = null_pointer; then echo "null_pointer"
147 else 160 else
148 echo "record type with name: $[((struct lrecord_implementation *)$imp)->name]" 161 echo "record type with name: $[((struct lrecord_implementation *)$imp)->name]"
149 fi 162 fi
163 }
164
165 function lisp-shadows {
166 run -batch -vanilla -f list-load-path-shadows
167 }
168
169 function environment-to-run-temacs {
170 unset EMACSLOADPATH
171 export EMACSBOOTSTRAPLOADPATH=../lisp/:..
172 export EMACSBOOTSTRAPMODULEPATH=../modules/:..
150 } 173 }
151 174
152 document run-temacs << 'end' 175 document run-temacs << 'end'
153 Usage: run-temacs 176 Usage: run-temacs
154 Run temacs interactively, like xemacs. 177 Run temacs interactively, like xemacs.
155 Use this with debugging tools (like purify) that cannot deal with dumping, 178 Use this with debugging tools (like purify) that cannot deal with dumping,
156 or when temacs builds successfully, but xemacs does not. 179 or when temacs builds successfully, but xemacs does not.
157 end 180 end
158 181
159 function run-temacs { 182 function run-temacs {
160 unset EMACSLOADPATH 183 environment-to-run-temacs
161 export EMACSBOOTSTRAPLOADPATH=../lisp/:..
162 run -batch -l ../lisp/loadup.el run-temacs -q 184 run -batch -l ../lisp/loadup.el run-temacs -q
163 } 185 }
164 186
165 document update-elc << 'end' 187 document update-elc << 'end'
166 Usage: update-elc 188 Usage: update-elc
168 Use when debugging temacs, not xemacs! 190 Use when debugging temacs, not xemacs!
169 Use this when temacs builds successfully, but xemacs does not. 191 Use this when temacs builds successfully, but xemacs does not.
170 end 192 end
171 193
172 function update-elc { 194 function update-elc {
173 unset EMACSLOADPATH 195 environment-to-run-temacs
174 export EMACSBOOTSTRAPLOADPATH=../lisp/:..
175 run -batch -l ../lisp/update-elc.el 196 run -batch -l ../lisp/update-elc.el
176 } 197 }
177 198
178 199
179 function dump-temacs { 200 function dump-temacs {
180 unset EMACSLOADPATH 201 environment-to-run-temacs
181 export EMACSBOOTSTRAPLOADPATH=../lisp/:..
182 run -batch -l ../lisp/loadup.el dump 202 run -batch -l ../lisp/loadup.el dump
183 } 203 }
184 204
185 document dump-temacs << 'end' 205 document dump-temacs << 'end'
186 Usage: dump-temacs 206 Usage: dump-temacs
204 Print the internal C structure of a underlying Lisp Object. 224 Print the internal C structure of a underlying Lisp Object.
205 end 225 end
206 226
207 function pobj { 227 function pobj {
208 decode_object $1 228 decode_object $1
209 if test $type = $dbg_Lisp_Type_Int; then 229 if test $type = $Lisp_Type_Int; then
210 print -f"Integer: %d" $val 230 print -f"Integer: %d" $val
211 elif test $type = $dbg_Lisp_Type_Char; then 231 elif test $type = $Lisp_Type_Char; then
212 if $val < 128; then 232 if test $[$val > 32 && $val < 128] = 1; then
213 print -f"Char: %c" $val 233 print -f"Char: %c" $val
214 else 234 else
215 print -f"Char: %d" $val 235 print -f"Char: %d" $val
216 fi 236 fi
217 elif test $type = $dbg_Lisp_Type_String || lrecord_type_p string; then 237 elif test $type = $Lisp_Type_String || lrecord_type_p string; then
218 pstruct Lisp_String 238 pstruct Lisp_String
219 elif test $type = $dbg_Lisp_Type_Cons || lrecord_type_p cons; then 239 elif test $type = $Lisp_Type_Cons || lrecord_type_p cons; then
220 pstruct Lisp_Cons 240 pstruct Lisp_Cons
221 elif test $type = $dbg_Lisp_Type_Symbol || lrecord_type_p symbol; then 241 elif test $type = $Lisp_Type_Symbol || lrecord_type_p symbol; then
222 pstruct Lisp_Symbol 242 pstruct Lisp_Symbol
223 echo "Symbol name: $[(char *)($xstruct->name->_data)]" 243 echo "Symbol name: $[(char *)($xstruct->name->data)]"
224 elif test $type = $dbg_Lisp_Type_Vector || lrecord_type_p vector; then 244 elif test $type = $Lisp_Type_Vector || lrecord_type_p vector; then
225 pstruct Lisp_Vector 245 pstruct Lisp_Vector
226 echo "Vector of length $[$xstruct->size]" 246 echo "Vector of length $[$xstruct->size]"
227 elif lrecord_type_p bit_vector; then 247 elif lrecord_type_p bit_vector; then
228 pstruct Lisp_Bit_Vector 248 pstruct Lisp_Bit_Vector
229 elif lrecord_type_p buffer; then 249 elif lrecord_type_p buffer; then
335 355
336 # Barf! 356 # Barf!
337 function print_shell { 357 function print_shell {
338 print *(`frame-x.c`TopLevelShellRec*) (((struct `frame-x.c`x_frame*) (((struct `frame-x.c`frame*) (Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget) 358 print *(`frame-x.c`TopLevelShellRec*) (((struct `frame-x.c`x_frame*) (((struct `frame-x.c`frame*) (Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget)
339 } 359 }
360
361 # -------------------------------------------------------------
362 # functions to test the debugging support itself.
363 # If you change this file, make sure the following still work...
364 # -------------------------------------------------------------
365 function test_xtype {
366 function doit { echo -n "$1: "; xtype "$1"; }
367 test_various_objects
368 }
369
370 function test_pobj {
371 function doit { echo '==============================='; echo -n "$1: "; pobj "$1"; }
372 test_various_objects
373 }
374
375 function test_various_objects {
376 doit Vemacs_major_version
377 doit Vhelp_char
378 doit Qnil
379 doit Qunbound
380 doit Vobarray
381 doit Vall_weak_lists
382 doit Vxemacs_codename
383 }