source: trunk/source/lib/backtrace.lisp @ 8942

Last change on this file since 8942 was 8942, checked in by gb, 11 years ago

In LOCAL-VALUE: don't insist that index < nargs ..

ARGUMENTS-AND-LOCALS: account for inherited vars (in closure), treat them
as locals.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 24.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; backtrace.lisp
18;;; low-level support for stack-backtrace printing
19
20(in-package "CCL")
21
22#+ppc-target (require "PPC-BACKTRACE")
23#+x86-target (require "X86-BACKTRACE")
24
25
26(defparameter *backtrace-show-internal-frames* nil)
27(defparameter *backtrace-print-level* 2)
28(defparameter *backtrace-print-length* 5)
29
30;;; This PRINTS the call history on *DEBUG-IO*.  It's more dangerous
31;;; (because of stack consing) to actually return it.
32                               
33(defun print-call-history (&key context
34                                (origin (%get-frame-ptr))
35                                (detailed-p t)
36                                (count most-positive-fixnum)
37                                (start-frame-number 0))
38  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))         
39    (if (eq tcr (%current-tcr))
40      (%print-call-history-internal context origin detailed-p (or count most-positive-fixnum) start-frame-number)
41      (unwind-protect
42           (progn
43             (%suspend-tcr tcr )
44             (%print-call-history-internal context origin  detailed-p
45                                           count start-frame-number))
46        (%resume-tcr tcr)))
47    (values)))
48
49(defun map-call-frames (fn &key context
50                           (origin (%get-frame-ptr))
51                           (start-frame-number 0)
52                           (include-internal nil))
53  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
54    (if (eq tcr (%current-tcr))
55      (%map-call-frames-internal fn context origin include-internal start-frame-number)
56      (unwind-protect
57           (progn
58             (%suspend-tcr tcr)
59             (%map-call-frames-internal fn context origin include-internal start-frame-number))
60        (%resume-tcr tcr))))
61  nil)
62
63(defun %show-stack-frame (p context lfun pc)
64  (handler-case
65      (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context)
66        (declare (fixnum count))
67        (dotimes (i count)
68          (multiple-value-bind (var type name) 
69                               (nth-value-in-frame p i context lfun pc vsp parent-vsp)
70            (format t "~&  ~D " i)
71            (when name (format t "~s" name))
72            (let* ((*print-length* *backtrace-print-length*)
73                   (*print-level* *backtrace-print-level*))
74              (format t ": ~s" var))
75            (when type (format t " (~S)" type)))))
76    (error () (format t "#<error printing frame>")))
77  (terpri)
78  (terpri))
79
80(defun %show-args-and-locals (p context lfun pc)
81  (handler-case
82      (let* ((unavailable (cons nil nil)))
83        (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable)
84          (format t "~&  ~s" (arglist-from-map lfun))
85          (let* ((*print-length* *backtrace-print-length*)
86                 (*print-level* *backtrace-print-level*))
87            (flet ((show-pair (pair prefix)
88                     (destructuring-bind (name . val) pair
89                       (format t "~&~a~s: " prefix name)
90                       (if (eq val unavailable)
91                         (format t "#<Unavailable>")
92                         (format t "~s" val)))))
93              (dolist (arg args)
94                (show-pair arg "   "))
95              (terpri)
96              (terpri)
97              (dolist (loc locals)
98                (show-pair loc "  "))))))
99    (error () (format t "#<error printing args and locals>")))
100  (terpri)
101  (terpri))
102
103
104(defun backtrace-call-arguments (context cfp lfun pc)
105  (collect ((call))
106    (let* ((name (function-name lfun)))
107      (if (function-is-current-definition? lfun)
108        (call name)
109        (progn
110          (call 'funcall)
111          (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))
112      (if (and pc (<= pc target::arg-check-trap-pc-limit))
113        (append (call) (arg-check-call-arguments cfp lfun))
114        (multiple-value-bind (req opt restp keys)
115            (function-args lfun)
116          (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
117            (let* ((arglist (arglist-from-map lfun)))
118              (if (or (null arglist) (null pc))
119                (call "???")
120                (progn
121                  (dotimes (i req)
122                    (let* ((val (argument-value context cfp lfun pc (pop arglist))))
123                      (if (eq val (%unbound-marker))
124                        (call "?")
125                        (call (let* ((*print-length* *backtrace-print-length*)
126                                     (*print-level* *backtrace-print-level*))
127                                (format nil "~s" val))))))
128                  (if (or restp keys (not (eql opt 0)))
129                    (call "[...]"))))))
130          (call))))))
131
132
133;;; Return a list of "interesting" frame addresses in context, most
134;;; recent first.
135(defun %stack-frames-in-context (context &optional (include-internal *backtrace-show-internal-frames*))
136  (collect ((frames))
137    (do* ((p (bt.youngest context) (parent-frame p context))
138          (q (bt.oldest context)))
139         ((eql p q) (frames))
140      (when (or (not (catch-csp-p p context)) include-internal)
141        (when (or (cfp-lfun p) include-internal)
142          (frames p))))))
143   
144(defun %map-call-frames-internal (fn context origin include-internal skip-initial)
145  (let ((*standard-output* *debug-io*)
146        (*print-circle* nil)
147        (p origin)
148        (q (last-frame-ptr context)))
149    (dotimes (i skip-initial)
150      (setq p (parent-frame p context))
151      (when (or (null p) (eq p q) (%stack< q p context))
152        (return (setq p nil))))
153    (do* ((p p (parent-frame p context)))
154         ((or (null p) (eq p q) (%stack< q p context)) nil)
155      (when (or include-internal
156                (and (not (catch-csp-p p context)) (cfp-lfun p)))
157        (funcall fn p)))))
158
159(defun %print-call-history-internal (context origin detailed-p
160                                             &optional (count most-positive-fixnum) (skip-initial 0))
161  (let ((*standard-output* *debug-io*)
162        (*print-circle* nil)
163        (*print-catch-errors* t)
164        (p origin)
165        (q (last-frame-ptr context)))
166    (dotimes (i skip-initial)
167      (setq p (parent-frame p context))
168      (when (or (null p) (eq p q) (%stack< q p context))
169        (return (setq p nil))))
170    (do* ((frame-number (or skip-initial 0) (1+ frame-number))
171          (i 0 (1+ i))
172          (p p (parent-frame p context)))
173         ((or (null p) (eq p q) (%stack< q p context)
174              (>= i count))
175          (values))
176      (declare (fixnum frame-number i))
177      (when (or (not (catch-csp-p p context))
178                *backtrace-show-internal-frames*)
179        (multiple-value-bind (lfun pc) (cfp-lfun p)
180          (when (or lfun *backtrace-show-internal-frames*)
181            (unless (and (typep detailed-p 'fixnum)
182                         (not (= (the fixnum detailed-p) frame-number)))
183              (format t "~&~c(~x) : ~D ~a ~d"
184                      (if (exception-frame-p p)  #\* #\space)
185                      (index->address p) frame-number
186                      (if lfun (backtrace-call-arguments context p lfun pc))
187                      pc)
188              (when detailed-p
189                (if (eq detailed-p :raw)
190                  (%show-stack-frame p context lfun pc)
191                  (%show-args-and-locals p context lfun pc))))))))))
192
193
194(defun %access-lisp-data (vstack-index)
195  (%fixnum-ref vstack-index))
196
197(defun %store-lisp-data (vstack-index value)
198  (setf (%fixnum-ref vstack-index) value))
199
200(defun closed-over-value (data)
201  (if (closed-over-value-p data)
202    (uvref data 0)
203    data))
204
205(defun set-closed-over-value (value-cell value)
206  (setf (uvref value-cell 0) value))
207
208
209
210;;; Act as if VSTACK-INDEX points at some lisp data & return that data.
211(defun access-lisp-data (vstack-index)
212  (closed-over-value (%access-lisp-data vstack-index)))
213
214(defun find-local-name (cellno lfun pc)
215  (let* ((n cellno))
216    (when lfun
217      (multiple-value-bind (mask where) (registers-used-by lfun pc)
218        (if (and where (< (1- where) n (+ where (logcount mask))))
219          (let ((j *saved-register-count*))
220            (decf n where)
221            (loop (loop (if (logbitp (decf j) mask) (return)))
222                  (if (< (decf n) 0) (return)))
223            (values (format nil "saved ~a" (aref *saved-register-names* j))
224                    nil))
225          (multiple-value-bind (nreq nopt restp nkeys junk optinitp junk ncells nclosed)
226                               (if lfun (function-args lfun))
227            (declare (ignore junk optinitp))
228            (if nkeys (setq nkeys (+ nkeys nkeys)))
229            (values
230             (if (and ncells (< n ncells))
231               (if (< n nclosed)
232                 :inherited
233                 (if (< (setq n (- n nclosed)) nreq)
234                   "required"
235                   (if (< (setq n (- n nreq)) nopt)
236                     "optional"
237                     (progn
238                       (setq n (- n nopt))
239                       (progn
240                         (if (and nkeys (< n nkeys))
241                           (if (not (logbitp 0 n)) ; a keyword
242                             "keyword"
243                             "key-supplied-p")
244                           (progn
245                             (if nkeys (setq n (- n nkeys)))
246                             (if (and restp (zerop n))
247                               "rest"
248                               "opt-supplied-p")))))))))
249             (match-local-name cellno (function-symbol-map lfun) pc))))))))
250
251(defun map-entry-value (context cfp lfun pc idx unavailable)
252  (declare (fixnum pc idx))
253  (let* ((info (function-symbol-map lfun)))
254    (if (null info)
255      unavailable
256      (let* ((addrs (cdr info))
257             (i (* 3 idx))
258             (addr (svref addrs i))
259             (startpc (svref addrs (the fixnum (+ i 1))))
260             (endpc (svref addrs (the fixnum (+ i 2)))))
261        (declare (fixnum i addr startpc endpc))
262        (if (or (< pc startpc)
263                (>= pc endpc))
264          unavailable
265          (let* ((value (if (= #o77 (ldb (byte 6 0) addr))
266                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
267                                         unavailable)
268                          (find-register-argument-value context cfp addr unavailable))))
269            (if (typep value 'value-cell)
270              (uvref value 0)
271              value)))))))
272
273;;; Returns non-nil on success (not newval)
274(defun set-map-entry-value (context cfp lfun pc idx newval)
275  (declare (fixnum pc idx))
276  (let* ((unavailable (cons nil nil))
277         (value (map-entry-value context cfp lfun pc idx unavailable)))
278    (if (eq value unavailable)
279      nil
280      (if (typep value 'value-cell)
281        (progn (setf (uvref value 0) newval) t)
282
283        (let* ((addrs (cdr (function-symbol-map lfun)))
284               (addr (svref addrs (the fixnum (* 3 idx)))))
285          (declare (fixnum  addr))
286          (if (= #o77 (ldb (byte 6 0) addr))
287            (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval)
288            (set-register-argument-value context cfp addr newval))
289          t)))))
290
291         
292(defun argument-value (context cfp lfun pc name &optional (quote t))
293  (declare (fixnum pc))
294  (let* ((info (function-symbol-map lfun))
295         (unavailable (%unbound-marker)))
296    (if (null info)
297      unavailable
298      (let* ((names (car info))
299             (addrs (cdr info)))
300        (do* ((nname (1- (length names)) (1- nname))
301              (naddr (- (length addrs) 3) (- naddr 3)))
302             ((or (< nname 0) (< naddr 0)) unavailable)
303          (declare (fixnum nname naddr))
304          (when (eq (svref names nname) name)
305            (let* ((value
306                    (let* ((addr (svref addrs naddr))
307                           (startpc (svref addrs (the fixnum (1+ naddr))))
308                           (endpc (svref addrs (the fixnum (+ naddr 2)))))
309                      (declare (fixnum addr startpc endpc))
310                      (if (or (< pc startpc)
311                              (>= pc endpc))
312                        unavailable
313                        (if (= #o77 (ldb (byte 6 0) addr))
314                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
315                                         unavailable)
316                          (find-register-argument-value context cfp addr unavailable))))))
317              (if (typep value 'value-cell)
318                (setq value (uvref value 0)))
319              (if (or (not quote) (self-evaluating-p value))
320                (return value)
321                (return (list 'quote value))))))))))
322
323
324
325(defun raw-frame-ref (cfp context index bad)
326  (%raw-frame-ref cfp context index bad))
327
328(defun raw-frame-set (cfp context index new)
329  (%raw-frame-set cfp context index new))
330 
331(defun find-register-argument-value (context cfp regval bad)
332  (%find-register-argument-value context cfp regval bad))
333
334(defun set-register-argument-value (context cfp regval newval)
335  (%set-register-argument-value context cfp regval newval))
336
337   
338
339(defun dbg-form (frame-number)
340  (when *break-frame*
341    (let* ((cfp (nth-raw-frame frame-number *break-frame* nil)))
342      (if (and cfp (not (catch-csp-p cfp nil)))
343        (multiple-value-bind (function pc)
344            (cfp-lfun cfp)
345          (if (and function
346                   (function-is-current-definition? function))
347            (block %cfp-form
348              (collect ((form))
349                (multiple-value-bind (nreq nopt restp keys allow-other-keys
350                                           optinit lexprp ncells nclosed)
351                    (function-args function)
352                  (declare (ignore ncells))
353                  (unless (or lexprp restp (> 0 nclosed) (> 0 nopt) keys allow-other-keys
354                              optinit)
355                    (let* ((name (function-name function)))
356                      (multiple-value-bind (arglist win)
357                          (arglist-from-map function)
358                      (when (and win name (symbolp name))
359                        (form name)
360                        (dotimes (i nreq)
361                          (let* ((val (argument-value nil cfp function pc (pop arglist))))
362                            (if (closed-over-value-p val)
363                              (setq val (%svref val target::value-cell.value-cell)))
364                            (if (eq val (%unbound-marker))
365                              (return-from %cfp-form nil))
366                            (form val))))))))
367                (form)))))))))
368
369(defun function-args (lfun)
370  "Returns 9 values, as follows:
371     req = number of required arguments
372     opt = number of optional arguments
373     restp = t if rest arg
374     keys = number of keyword arguments or NIL if &key not mentioned
375     allow-other-keys = t if &allow-other-keys present
376     optinit = t if any optional arg has non-nil default value or supplied-p
377               variable
378     lexprp = t if function is a lexpr, in which case all other values are
379              undefined.
380     ncells = number of stack frame cells used by all arguments.
381     nclosed = number of inherited values (now counted distinctly from required)
382     All numeric values (but ncells) are mod 64."
383  (let* ((bits (lfun-bits lfun))
384         (req (ldb $lfbits-numreq bits))
385         (opt (ldb $lfbits-numopt bits))
386         (restp (logbitp $lfbits-rest-bit bits))
387         (keyvect (lfun-keyvect lfun))
388         (keys (and keyvect (length keyvect)))
389         (allow-other-keys (logbitp $lfbits-aok-bit bits))
390         (optinit (logbitp $lfbits-optinit-bit bits))
391         (lexprp (logbitp $lfbits-restv-bit bits))
392         (nclosed (ldb $lfbits-numinh bits)))
393    (values req opt restp keys allow-other-keys optinit lexprp
394            (unless (or lexprp)
395              (+ req opt (if restp 1 0) (if keys (+ keys keys) 0)
396                 (if optinit opt 0) nclosed))
397            nclosed)))
398
399;;; If we can tell reliably, return the function's minimum number of
400;;; non-inherited arguments, the maximum number of such arguments (or NIL),
401;;; and the actual number of such arguments.  We "can't tell" if either
402;;; of the arguments to this function are null, and we can't tell reliably
403;;; if any of the lfbits fields are full.
404(defun min-max-actual-args (fn nargs)
405  (let* ((lfbits (if (and fn nargs)
406                   (lfun-bits fn)
407                   -1))
408         (raw-req (ldb $lfbits-numreq lfbits))
409         (raw-opt (ldb $lfbits-numopt lfbits))
410         (raw-inh (ldb $lfbits-numinh lfbits)))
411    (declare (fixnum raw-req raw-opt raw-inh))
412    (if (or (eql raw-req (1- (ash 1 (byte-size $lfbits-numreq))))
413            (eql raw-opt (1- (ash 1 (byte-size $lfbits-numopt))))
414            (eql raw-inh (1- (ash 1 (byte-size $lfbits-numinh)))))
415      (values nil nil nil)
416      (values raw-req
417              (unless (or (lfun-keyvect fn)
418                          (logbitp $lfbits-rest-bit lfbits)
419                          (logbitp $lfbits-restv-bit lfbits))
420                (+ raw-req raw-opt))
421              (- nargs raw-inh)))))
422
423
424
425(defun closed-over-value-p (value)
426  (eql target::subtag-value-cell (typecode value)))
427
428
429(defun variables-in-scope (lfun pc)
430  ;; Return a list of all symbol names "in scope" in the function lfun
431  ;; at relative program counter PC, using the function's symbol map.
432  ;; The list will be ordered so that least-recent bindings appear first.
433  ;; Return a list of the matching symbol map entries as a second value
434  (when pc
435    (locally (declare (fixnum pc))
436      (let* ((map (function-symbol-map lfun))
437             (names (car map))
438             (info (cdr map)))
439        (when map
440          (let* ((vars ())
441                 (indices ()))
442            (dotimes (i (length names) (values vars indices))
443              (let* ((start-pc (aref info (1+ (* 3 i))))
444                     (end-pc (aref info (+ 2 (* 3 i)))))
445                (declare (fixnum start-pc end-pc))
446                (when (and (>= pc start-pc)
447                           (< pc end-pc))
448                  (push i indices)
449                  (push (svref names i) vars))))))))))
450
451
452(defun arg-value (context cfp lfun pc unavailable name)
453  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
454    (multiple-value-bind (valid req opt rest keys)
455        (arg-names-from-map lfun pc)
456      (if valid
457        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
458               (pos (position name vars)))
459          (if (and pos (< pos nargs))
460            (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable)
461            unavailable))
462        unavailable))))
463
464(defun local-value (context cfp lfun pc unavailable name)
465  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
466    (multiple-value-bind (valid req opt rest keys)
467        (arg-names-from-map lfun pc)
468      (if valid
469        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
470               (names (nthcdr nargs vars))
471               (indices (nthcdr nargs map-indices))
472               (pos (if (typep name 'unsigned-byte)
473                      name
474                      (position name names :from-end t))))
475          (if (and pos (< pos nargs))
476            (map-entry-value context cfp lfun pc (nth pos indices) unavailable)
477            unavailable))
478        unavailable))))
479
480(defun set-arg-value (context cfp lfun pc name new)
481  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
482    (multiple-value-bind (valid req opt rest keys)
483        (arg-names-from-map lfun pc)
484      (if valid
485        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
486               (pos (position name vars)))
487          (when (and pos (< pos nargs))
488            (set-map-entry-value context cfp lfun pc (nth pos map-indices) new)))))))
489
490(defun set-local-value (context cfp lfun pc name new)
491  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
492    (multiple-value-bind (valid req opt rest keys)
493        (arg-names-from-map lfun pc)
494      (if valid
495        (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
496               (names (nthcdr nargs vars))
497               (indices (nthcdr nargs map-indices))
498               (pos (if (typep name 'unsigned-byte)
499                      name
500                      (position name names :from-end t))))
501          (if (and pos (< pos nargs))
502            (set-map-entry-value context cfp lfun pc (nth pos indices) new)))))))
503
504
505(defun arguments-and-locals (context cfp lfun pc &optional unavailable)
506  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
507    (collect ((args)
508              (inherited-indices)
509              (inherited-vars)
510              (locals))
511      (multiple-value-bind (valid req opt rest keys)
512          (arg-names-from-map lfun pc)
513        (when valid
514          (let* ((numinh (ldb $lfbits-numinh (lfun-bits lfun))))
515            (dotimes (i numinh)
516              (inherited-indices (pop map-indices))
517              (inherited-vars (pop vars))))
518          (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
519                 (nlocals (- (length vars) nargs))
520                 (local-vars (append (nthcdr nargs vars) (inherited-vars)))
521                 (local-indices (append (nthcdr nargs map-indices) (inherited-indices)))
522                 (arg-vars (nbutlast vars nlocals))
523                 (arg-indices (nbutlast map-indices nlocals)))
524            (flet ((get-arg-value (name)
525                     (let* ((pos (position name arg-vars :test #'eq)))
526                       (when pos
527                         (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable))))))
528                   (get-local-value (name)
529                     (when name
530                       (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable))))))
531              (dolist (name req)
532                (get-arg-value name))
533              (dolist (name opt)
534                (get-arg-value name))
535              (when rest
536                (get-arg-value rest))
537              (dolist (name keys)
538                (get-arg-value name))
539              (dolist (name local-vars)
540                (get-local-value name)))))
541        (values (args) (locals))))))
542                   
543           
544
545(defun safe-cell-value (val)
546  val)
547
548(defun closure-closed-over-values (closure)
549  (when (typep closure 'compiled-lexical-closure)
550    (let* ((inner (closure-function closure))
551           (nclosed (nth-value 8 (function-args inner)))
552           (names (car (function-symbol-map inner))))
553      (when nclosed
554        (collect ((cells))
555          (do* ((i (1- (length names)) (1- i))
556                (k 0 (1+ k))
557                (idx 2 (1+ idx)))
558               ((= k nclosed) (reverse (cells)))
559            (let* ((name (svref names i))
560                   (imm (nth-immediate closure idx)))
561              (cells (list name (if (closed-over-value-p imm)
562                                  (closed-over-value imm)
563                                  imm))))))))))
564
565     
566;;; Find the oldest binding frame that binds the same symbol as
567;;; FRAME in context.  If found, return the saved value of that
568;;; binding, else the value of the symbol in the context's thread.
569(defun oldest-binding-frame-value (context frame)
570  (let* ((oldest nil)
571         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
572    (do* ((db (db-link context) (%fixnum-ref db 0)))
573         ((eq frame db)
574          (if oldest
575            (%fixnum-ref oldest (ash 2 target::fixnum-shift))
576            (let* ((symbol (binding-index-symbol binding-index)))
577              (if context
578                (symbol-value-in-tcr symbol (bt.tcr context))
579                (%sym-value symbol)))))
580      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
581        (setq oldest db)))))
582
583(defun (setf oldest-binding-frame-value) (new context frame)
584  (let* ((oldest nil)
585         (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift))))
586    (do* ((db (db-link context) (%fixnum-ref db 0)))
587         ((eq frame db)
588          (if oldest
589            (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new)
590            (let* ((symbol (binding-index-symbol binding-index)))
591              (if context
592                (setf (symbol-value-in-tcr symbol (bt.tcr context)) new)
593                (%set-sym-value symbol new)))))
594      (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index)
595        (setq oldest db)))))
596   
597
598
599;;; End of backtrace.lisp
Note: See TracBrowser for help on using the repository browser.