Changeset 7367 for trunk/ccl/lib/backtrace.lisp
- Timestamp:
- Oct 8, 2007, 2:54:19 AM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/lib/backtrace.lisp
r6928 r7367 63 63 64 64 (defun %show-args-and-locals (p context lfun pc) 65 (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc) 66 (format t "~& ~s" (arglist-from-map lfun)) 67 (let* ((*print-length* *backtrace-print-length*) 68 (*print-level* *backtrace-print-level*)) 69 (flet ((show-pair (pair prefix) 70 (destructuring-bind (name . val) pair 71 (format t "~&~a~s: " prefix name) 72 (if (eq val (%unbound-marker)) 73 (format t "#<Unavailable>") 74 (format t "~s" val))))) 75 (dolist (arg args) 76 (show-pair arg " ")) 77 (terpri) 78 (terpri) 79 (dolist (loc locals) 80 (show-pair loc " ")) 81 (terpri) 82 (terpri))))) 65 (let* ((unavailable (cons nil nil))) 66 (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable) 67 (format t "~& ~s" (arglist-from-map lfun)) 68 (let* ((*print-length* *backtrace-print-length*) 69 (*print-level* *backtrace-print-level*)) 70 (flet ((show-pair (pair prefix) 71 (destructuring-bind (name . val) pair 72 (format t "~&~a~s: " prefix name) 73 (if (eq val unavailable) 74 (format t "#<Unavailable>") 75 (format t "~s" val))))) 76 (dolist (arg args) 77 (show-pair arg " ")) 78 (terpri) 79 (terpri) 80 (dolist (loc locals) 81 (show-pair loc " ")) 82 (terpri) 83 (terpri)))))) 83 84 84 85 … … 212 213 (match-local-name cellno (function-symbol-map lfun) pc)))))))) 213 214 215 (defun map-entry-value (context cfp lfun pc idx unavailable) 216 (declare (fixnum pc idx)) 217 (let* ((info (function-symbol-map lfun))) 218 (if (null info) 219 unavailable 220 (let* ((addrs (cdr info)) 221 (i (* 3 idx)) 222 (addr (svref addrs i)) 223 (startpc (svref addrs (the fixnum (+ i 1)))) 224 (endpc (svref addrs (the fixnum (+ i 2))))) 225 (declare (fixnum i addr startpc endpc)) 226 (if (or (< pc startpc) 227 (>= pc endpc)) 228 unavailable 229 (let* ((value (if (= #o77 (ldb (byte 6 0) addr)) 230 (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6))) 231 unavailable) 232 (find-register-argument-value context cfp addr unavailable)))) 233 (if (typep value 'value-cell) 234 (uvref value 0) 235 value))))))) 236 214 237 (defun argument-value (context cfp lfun pc name &optional (quote t)) 215 238 (declare (fixnum pc)) … … 346 369 ;; at relative program counter PC, using the function's symbol map. 347 370 ;; The list will be ordered so that least-recent bindings appear first. 371 ;; Return a list of the matching symbol map entries as a second value 348 372 (when pc 349 373 (locally (declare (fixnum pc)) … … 352 376 (info (cdr map))) 353 377 (when map 354 (let* ((vars ())) 355 (dotimes (i (length names) vars) 378 (let* ((vars ()) 379 (indices ())) 380 (dotimes (i (length names) (values vars indices)) 356 381 (let* ((start-pc (aref info (1+ (* 3 i)))) 357 382 (end-pc (aref info (+ 2 (* 3 i))))) … … 359 384 (when (and (>= pc start-pc) 360 385 (< pc end-pc)) 386 (push i indices) 361 387 (push (svref names i) vars)))))))))) 362 388 363 (defun arguments-and-locals (context cfp lfun pc )364 ( let* ((vars (variables-in-scope lfun pc)))389 (defun arguments-and-locals (context cfp lfun pc unavailable) 390 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 365 391 (collect ((args) 366 392 (locals)) 367 (multiple-value-bind (valid req opt rest keys) 368 (arg-names-from-map lfun pc) 369 (when valid 370 (flet ((get-arg-value (name) 371 (let* ((avail (member name vars :test #'eq))) 372 (if avail 373 (setf (car (member name vars :test #'eq)) nil)) 374 (args (cons name (argument-value context cfp lfun pc name nil))))) 375 (get-local-value (name) 376 (when name 377 (locals (cons name (argument-value context cfp lfun pc name nil)))))) 378 (dolist (name req) 379 (get-arg-value name)) 380 (dolist (name opt) 381 (get-arg-value name)) 382 (when rest 383 (get-arg-value rest)) 384 (dolist (name keys) 385 (get-arg-value name)) 386 (dolist (name vars) 387 (get-local-value name)))) 388 (values (args) (locals)))))) 393 (multiple-value-bind (valid req opt rest keys) 394 (arg-names-from-map lfun pc) 395 (when valid 396 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 397 (nlocals (- (length vars) nargs)) 398 (local-vars (nthcdr nargs vars)) 399 (local-indices (nthcdr nargs map-indices)) 400 (arg-vars (nbutlast vars nlocals)) 401 (arg-indices (nbutlast map-indices nlocals))) 402 (flet ((get-arg-value (name) 403 (let* ((pos (position name arg-vars :test #'eq))) 404 (when pos 405 (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable)))))) 406 (get-local-value (name) 407 (when name 408 (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable)))))) 409 (dolist (name req) 410 (get-arg-value name)) 411 (dolist (name opt) 412 (get-arg-value name)) 413 (when rest 414 (get-arg-value rest)) 415 (dolist (name keys) 416 (get-arg-value name)) 417 #+no 418 (setq local-vars (nreverse local-vars) 419 local-indices (nreverse local-indices)) 420 (dolist (name local-vars) 421 (get-local-value name))))) 422 (values (args) (locals)))))) 389 423 390 424
Note: See TracChangeset
for help on using the changeset viewer.