Changeset 7409 for branches/working-0710


Ignore:
Timestamp:
Oct 12, 2007, 9:46:10 AM (12 years ago)
Author:
gb
Message:

Implement setting frame values.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0710/ccl/lib/backtrace.lisp

    r7368 r7409  
    235235              value)))))))
    236236
     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         
    237256(defun argument-value (context cfp lfun pc name &optional (quote t))
    238257  (declare (fixnum pc))
     
    270289(defun raw-frame-ref (cfp context index bad)
    271290  (%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))
    272294 
    273295(defun find-register-argument-value (context cfp regval bad)
    274296  (%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
    275301   
    276302
     
    386412                  (push i indices)
    387413                  (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
    388468
    389469(defun arguments-and-locals (context cfp lfun pc &optional unavailable)
     
    461541      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
    462542        (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)))))
    463557   
    464558
Note: See TracChangeset for help on using the changeset viewer.