Changeset 7409 for branches/working-0710/ccl/lib/backtrace.lisp
- Timestamp:
- Oct 12, 2007, 9:46:10 AM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0710/ccl/lib/backtrace.lisp
r7368 r7409 235 235 value))))))) 236 236 237 ;;; Returns non-nil on success (not newval) 238 (defun set-map-entry-value (context cfp lfun pc idx newval) 239 (declare (fixnum pc idx)) 240 (let* ((unavailable (cons nil nil)) 241 (value (map-entry-value context cfp lfun pc idx unavailable))) 242 (if (eq value unavailable) 243 nil 244 (if (typep value 'value-cell) 245 (progn (setf (uvref value 0) newval) t) 246 247 (let* ((addrs (cdr (function-symbol-map lfun))) 248 (addr (svref addrs (the fixnum (* 3 idx))))) 249 (declare (fixnum addr)) 250 (if (= #o77 (ldb (byte 6 0) addr)) 251 (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval) 252 (set-register-argument-value context cfp addr newval)) 253 t))))) 254 255 237 256 (defun argument-value (context cfp lfun pc name &optional (quote t)) 238 257 (declare (fixnum pc)) … … 270 289 (defun raw-frame-ref (cfp context index bad) 271 290 (%raw-frame-ref cfp context index bad)) 291 292 (defun raw-frame-set (cfp context index new) 293 (%raw-frame-set cfp context index new)) 272 294 273 295 (defun find-register-argument-value (context cfp regval bad) 274 296 (%find-register-argument-value context cfp regval bad)) 297 298 (defun set-register-argument-value (context cfp regval newval) 299 (%set-register-argument-value context cfp regval newval)) 300 275 301 276 302 … … 386 412 (push i indices) 387 413 (push (svref names i) vars)))))))))) 414 415 416 (defun arg-value (context cfp lfun pc unavailable name) 417 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 418 (multiple-value-bind (valid req opt rest keys) 419 (arg-names-from-map lfun pc) 420 (if valid 421 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 422 (pos (position name vars))) 423 (if (and pos (< pos nargs)) 424 (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable) 425 unavailable)) 426 unavailable)))) 427 428 (defun local-value (context cfp lfun pc unavailable name) 429 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 430 (multiple-value-bind (valid req opt rest keys) 431 (arg-names-from-map lfun pc) 432 (if valid 433 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 434 (names (nthcdr nargs vars)) 435 (indices (nthcdr nargs map-indices)) 436 (pos (if (typep name 'unsigned-byte) 437 name 438 (position name names :from-end t)))) 439 (if (and pos (< pos nargs)) 440 (map-entry-value context cfp lfun pc (nth pos indices) unavailable) 441 unavailable)) 442 unavailable)))) 443 444 (defun set-arg-value (context cfp lfun pc name new) 445 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 446 (multiple-value-bind (valid req opt rest keys) 447 (arg-names-from-map lfun pc) 448 (if valid 449 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 450 (pos (position name vars))) 451 (when (and pos (< pos nargs)) 452 (set-map-entry-value context cfp lfun pc (nth pos map-indices) new))))))) 453 454 (defun set-local-value (context cfp lfun pc name new) 455 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 456 (multiple-value-bind (valid req opt rest keys) 457 (arg-names-from-map lfun pc) 458 (if valid 459 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 460 (names (nthcdr nargs vars)) 461 (indices (nthcdr nargs map-indices)) 462 (pos (if (typep name 'unsigned-byte) 463 name 464 (position name names :from-end t)))) 465 (if (and pos (< pos nargs)) 466 (set-map-entry-value context cfp lfun pc (nth pos indices) new))))))) 467 388 468 389 469 (defun arguments-and-locals (context cfp lfun pc &optional unavailable) … … 461 541 (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) 462 542 (setq oldest db))))) 543 544 (defun (setf oldest-binding-frame-value) (new context frame) 545 (let* ((oldest nil) 546 (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) 547 (do* ((db (db-link context) (%fixnum-ref db 0))) 548 ((eq frame db) 549 (if oldest 550 (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new) 551 (let* ((symbol (binding-index-symbol binding-index))) 552 (if context 553 (setf (symbol-value-in-tcr symbol (bt.tcr context)) new) 554 (%set-sym-value symbol new))))) 555 (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) 556 (setq oldest db))))) 463 557 464 558
Note: See TracChangeset
for help on using the changeset viewer.