source: trunk/ccl/lib/backtrace-lds.lisp @ 7255

Last change on this file since 7255 was 7255, checked in by gb, 12 years ago

FRAME-REQUIRED-ARGS: try to make better. This is only used by SLIME;
it was once used for frame restarting. Try to make the result reasonable
in the SLIME case.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 23.7 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-lds.lisp
18;;; low-level support for stack-backtrace dialog (Lisp Development System)
19
20(in-package "CCL")
21
22
23(defparameter *saved-register-count*
24  #+x8664-target 4
25  #+ppc-target 8)
26
27(defparameter *saved-register-names*
28  #+x8664-target #(save3 save2 save1 save0)
29  #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0))
30
31
32;;; Returns three values: (ARG-VALUES TYPES NAMES), solely for the benefit
33;;; of the FRAME-ARGUMENTS function in SLIME's swank-openmcl.lisp.
34;;; ARG-VALUES is a list of the values of the args supplied to the function
35;;; TYPES is a list of (for bad historical reasons) strings .describing
36;;;   whether they're "required", "optional", etc.  SLIME only really
37;;;   cares about whether this is equal to "keyword" or not.
38;;; NAMES is a list of symbols which name the args.
39(defun frame-supplied-args (frame lfun pc child context)
40  (declare (ignore child))
41  (let* ((arglist (arglist-from-map lfun))
42         (args (arguments-and-locals context frame lfun pc))
43         (state :required))
44    (collect ((arg-values)
45              (types)
46              (names))
47      (dolist (arg arglist)
48        (if (or (member arg lambda-list-keywords)
49                (eq arg '&lexpr))
50          (setq state arg)
51          (let* ((pair (pop args)))
52            (case state
53              (&lexpr
54               (with-list-from-lexpr (rest (cdr pair))
55                 (dolist (r rest) (arg-values r) (names nil) (types nil)))
56               (return))
57              (&rest
58               (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
59               (return))
60              (&key
61               (arg-values arg)
62               (names nil)
63               (types nil)))
64            (let* ((value (cdr pair)))
65              (if (eq value (%unbound-marker))
66                (return))
67              (names (car pair))
68              (arg-values value)
69              (types nil)))))
70      (values (arg-values) (types) (names)))))
71
72;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
73;;; pretty PPC-specific
74#+ppc-target
75(progn
76;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
77(defun set-lisp-data (vstack-index data)
78  (let* ((old (%access-lisp-data vstack-index)))
79    (if (closed-over-value-p old)
80      (set-closed-over-value old data)
81      (%store-lisp-data vstack-index data))))
82
83
84;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
85;;
86;;extensions to let user access and modify values
87
88
89
90
91
92;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"
93
94
95
96
97
98
99(defparameter *saved-register-count+1*
100  (1+ *saved-register-count*))
101
102
103
104(defparameter *saved-register-numbers*
105  #+x8664-target #(wrong)
106  #+ppc-target #(31 30 29 28 27 26 25 24))
107
108;;; Don't do unbound checks in compiled code
109(declaim (type t *saved-register-count* *saved-register-count+1*
110               *saved-register-names* *saved-register-numbers*))
111
112(defmacro %cons-saved-register-vector ()
113  `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))
114
115(defun copy-srv (from-srv &optional to-srv)
116  (if to-srv
117    (if (eq from-srv to-srv)
118      to-srv
119      (dotimes (i (uvsize from-srv) to-srv)
120        (setf (uvref to-srv i) (uvref from-srv i))))
121    (copy-uvector from-srv)))
122
123(defmacro srv.unresolved (saved-register-vector)
124  `(svref ,saved-register-vector 0))
125
126(defmacro srv.register-n (saved-register-vector n)
127  `(svref ,saved-register-vector (1+ ,n)))
128
129;;; This isn't quite right - has to look at all functions on stack,
130;;; not just those that saved VSPs.
131
132
133(defun frame-restartable-p (target &optional context)
134  (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
135    (when frame
136      (loop
137        (when (null frame)
138          (return-from frame-restartable-p nil))
139        (when (eq frame target) (return))
140        (multiple-value-setq (frame last-catch srv)
141          (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
142      (when (and srv (eql 0 (srv.unresolved srv)))
143        (setf (srv.unresolved srv) last-catch)
144        srv))))
145
146
147;;; get the saved register addresses for this frame
148;;; still need to worry about this unresolved business
149;;; could share some code with parent-frame-saved-vars
150(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
151  (let ((unresolved 0))
152    (multiple-value-bind (lfun pc) (cfp-lfun frame)
153        (if lfun
154          (multiple-value-bind (mask where) (registers-used-by lfun pc)
155            (when mask
156              (if (not where) 
157                (setq unresolved (%ilogior unresolved mask))
158                (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
159                      (j *saved-register-count*))
160                  (declare (fixnum j))
161                  (dotimes (i j)
162                    (declare (fixnum i))
163                    (when (%ilogbitp (decf j) mask)
164                      (setf (srv.register-n srv-out i) vsp
165                            vsp (1+ vsp)
166                            unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
167          (setq unresolved (1- (ash 1 *saved-register-count*)))))
168    (setf (srv.unresolved srv-out) unresolved)
169    srv-out))
170
171(defun parent-frame-saved-vars 
172       (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
173  (copy-srv srv srv-out)
174  (let* ((parent (and frame (parent-frame frame context)))
175         (grand-parent (and parent (parent-frame parent context))))
176    (when grand-parent
177      (loop (let ((next-catch (and last-catch (next-catch last-catch))))
178              ;(declare (ignore next-catch))
179              (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
180                (progn
181                  (setf last-catch next-catch
182                        (srv.unresolved srv-out) 0)
183                  (dotimes (i *saved-register-count*)
184                    (setf (srv.register-n srv i) nil)))
185                (return))))
186      (lookup-registers parent context grand-parent srv-out)
187      (values parent last-catch srv-out))))
188
189(defun lookup-registers (parent context grand-parent srv-out)
190  (unless (or (eql (frame-vsp grand-parent) 0)
191              (let ((gg-parent (parent-frame grand-parent context)))
192                (eql (frame-vsp gg-parent) 0)))
193    (multiple-value-bind (lfun pc) (cfp-lfun parent)
194      (when lfun
195        (multiple-value-bind (mask where) (registers-used-by lfun pc)
196          (when mask
197            (locally (declare (fixnum mask))
198              (if (not where) 
199                (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
200                (let* ((grand-parent-vsp (frame-vsp grand-parent)))
201
202                  (let ((vsp (- grand-parent-vsp where 1))
203                        (j *saved-register-count*))
204                    (declare (fixnum j))
205                    (dotimes (i j)
206                      (declare (fixnum i))
207                      (when (%ilogbitp (decf j) mask)
208                        (setf (srv.register-n srv-out i) vsp
209                              vsp (1- vsp)
210                              (srv.unresolved srv-out)
211                              (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))
212
213;;; initialization for looping on parent-frame-saved-vars
214(defun last-catch-since-saved-vars (frame context)
215  (let* ((parent (parent-frame frame context))
216         (last-catch (and parent (last-catch-since parent context))))
217    (when last-catch
218      (let ((frame (catch-frame-sp last-catch))
219            (srv (%cons-saved-register-vector)))
220        (setf (srv.unresolved srv) 0)
221        (let* ((parent (parent-frame frame context))
222               (child (and parent (child-frame parent context))))
223          (when child
224            (lookup-registers child context parent srv))
225          (values child last-catch srv))))))
226
227;;; Returns 2 values:
228;;; mask srv
229;;; The mask says which registers are used at PC in LFUN.  srv is a
230;;; saved-register-vector whose register contents are the register
231;;; values registers whose bits are not set in MASK or set in
232;;; UNRESOLVED will be returned as NIL.
233
234(defun saved-register-values 
235       (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
236  (declare (ignore child))
237  (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
238        ((eq srv-out srv))
239        (t (dotimes (i (the fixnum (uvsize srv)))
240             (setf (uvref srv-out i) (uvref srv i)))))
241  (let ((mask (or (registers-used-by lfun pc) 0))
242        (unresolved (srv.unresolved srv))
243        (j *saved-register-count*))
244    (declare (fixnum j))
245    (dotimes (i j)
246      (declare (fixnum i))
247      (setf (srv.register-n srv-out i)
248            (and (%ilogbitp (setq j (%i- j 1)) mask)
249                 (not (%ilogbitp j unresolved))
250                 (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
251    (setf (srv.unresolved srv-out) mask)
252    (values mask srv-out)))
253
254; Set the nth saved register to value.
255(defun set-saved-register (value n lfun pc child last-catch srv)
256  (declare (ignore lfun pc child) (dynamic-extent saved-register-values))
257  (let ((j (- target::node-size n))
258        (unresolved (srv.unresolved srv))
259        (addr (srv.register-n srv n)))
260    (when (logbitp j unresolved)
261      (error "Can't set register ~S to ~S" n value))
262    (set-register-value value addr last-catch j))
263  value)
264
265
266
267
268
269(defun return-from-nth-frame (n &rest values)
270  (apply-in-nth-frame n #'values values))
271
272(defun apply-in-nth-frame (n fn arglist)
273  (let* ((bt-info (car *backtrace-contexts*)))
274    (and bt-info
275         (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
276           (and frame (apply-in-frame frame fn arglist)))))
277  (format t "Can't return to frame ~d ." n))
278
279;;; This method is shadowed by one for the backtrace window.
280(defmethod nth-frame (w target n context)
281  (declare (ignore w))
282  (and target (dotimes (i n target)
283                (declare (fixnum i))
284                (unless (setq target (parent-frame target context)) (return nil)))))
285
286; If this returns at all, it's because the frame wasn't restartable.
287(defun apply-in-frame (frame fn arglist &optional context)
288  (let* ((srv (frame-restartable-p frame context))
289         (target-sp (and srv (srv.unresolved srv))))
290    (if target-sp
291      (apply-in-frame-internal context frame fn arglist srv))))
292
293(defun apply-in-frame-internal (context frame fn arglist srv)
294  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
295    (if (eq tcr (%current-tcr))
296      (%apply-in-frame frame fn arglist srv)
297      (let ((process (tcr->process tcr)))
298        (if process
299          (process-interrupt
300           process
301           #'%apply-in-frame
302           frame fn arglist srv)
303          (error "Can't find active process for ~s" tcr))))))
304
305
306
307
308;;; (srv.unresolved srv) is the last catch frame, left there by
309;;; frame-restartable-p The registers in srv are locations of
310;;; variables saved between frame and that catch frame.
311(defun %apply-in-frame (frame fn arglist srv)
312  (declare (fixnum frame))
313  (let* ((catch (srv.unresolved srv))
314         (tsp-count 0)
315         (tcr (%current-tcr))
316         (parent (parent-frame frame tcr))
317         (vsp (frame-vsp parent))
318         (catch-top (%catch-top tcr))
319         (db-link (%svref catch target::catch-frame.db-link-cell))
320         (catch-count 0))
321    (declare (fixnum parent vsp db-link catch-count))
322    ;; Figure out how many catch frames to throw through
323    (loop
324      (unless catch-top
325        (error "Didn't find catch frame"))
326      (incf catch-count)
327      (when (eq catch-top catch)
328        (return))
329      (setq catch-top (next-catch catch-top)))
330    ;; Figure out where the db-link should be
331    (loop
332      (when (or (eql db-link 0) (>= db-link vsp))
333        (return))
334      (setq db-link (%fixnum-ref db-link)))
335    ;; Figure out how many TSP frames to pop after throwing.
336    (let ((sp (catch-frame-sp catch)))
337      (loop
338        (multiple-value-bind (f pc) (cfp-lfun sp)
339          (when f (incf tsp-count (active-tsp-count f pc))))
340        (setq sp (parent-frame sp tcr))
341        (when (eql sp parent) (return))
342        (unless sp (error "Didn't find frame: ~s" frame))))
343    #+debug
344    (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
345            catch-count srv tsp-count db-link parent fn arglist)
346    (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))
347
348
349
350
351;;;;;;;;;;;;;;;;;;;;;;;
352;;;
353;;; Code to determine how many tsp frames to pop.
354;;; This is done by parsing the code.
355;;; active-tsp-count is the entry point below.
356;;;
357
358#+ppc-target
359(progn
360
361(defstruct (branch-tree (:print-function print-branch-tree))
362  first-instruction
363  last-instruction
364  branch-target     ; a branch-tree or nil
365  fall-through)     ; a branch-tree or nil
366
367(defun print-branch-tree (tree stream print-level)
368  (declare (ignore print-level))
369  (print-unreadable-object (tree stream :type t :identity t)
370    (format stream "~s-~s"
371            (branch-tree-first-pc tree)
372            (branch-tree-last-pc tree))))
373
374(defun branch-tree-first-pc (branch-tree)
375  (let ((first (branch-tree-first-instruction branch-tree)))
376    (and first (instruction-element-address first))))
377
378(defun branch-tree-last-pc (branch-tree)
379  (let ((last (branch-tree-last-instruction branch-tree)))
380    (if last
381      (instruction-element-address last)
382      (branch-tree-first-pc branch-tree))))
383
384(defun branch-tree-contains-pc-p (branch-tree pc)
385  (<= (branch-tree-first-pc branch-tree)
386      pc
387      (branch-tree-last-pc branch-tree)))
388
389(defvar *branch-tree-hash*
390  (make-hash-table :test 'eq :weak :value))
391
392(defun get-branch-tree (function)
393  (or (gethash function *branch-tree-hash*)
394      (let* ((dll (function-to-dll-header function))
395             (tree (dll-to-branch-tree dll)))
396        (setf (gethash function *branch-tree-hash*) tree))))         
397
398; Return the number of TSP frames that will be active after throwing out
399; of all the active catch frames in function at pc.
400; PC is a byte address, a multiple of 4.
401(defun active-tsp-count (function pc)
402  (setq function
403        (require-type
404         (if (symbolp function)
405           (symbol-function function)
406           function)
407         'compiled-function))
408  (let* ((tree (get-branch-tree function))
409         (visited nil))
410    (labels ((find-pc (branch path)
411               (unless (memq branch visited)
412                 (push branch path)
413                 (if (branch-tree-contains-pc-p branch pc)
414                   path
415                   (let ((target (branch-tree-branch-target branch))
416                         (fall-through (branch-tree-fall-through branch)))
417                     (push branch visited)
418                     (if fall-through
419                       (or (and target (find-pc target path))
420                           (find-pc fall-through path))
421                       (and target (find-pc target path))))))))
422      (let* ((path (nreverse (find-pc tree nil)))
423             (last-tree (car (last path)))
424             (catch-count 0)
425             (tsp-count 0))
426        (unless path
427          (error "Can't find path to pc: ~s in ~s" pc function))
428        (dolist (tree path)
429          (let ((next (branch-tree-first-instruction tree))
430                (last (branch-tree-last-instruction tree)))
431            (loop
432              (when (and (eq tree last-tree)
433                         (eql pc (instruction-element-address next)))
434                ; If the instruction before the current one is an ff-call,
435                ; then callback pushed a TSP frame.
436                #| ; Not any more
437                (when (ff-call-instruction-p (dll-node-pred next))
438                  (incf tsp-count))
439                |#
440                (return))
441              (multiple-value-bind (type target fall-through count) (categorize-instruction next)
442                (declare (ignore target fall-through))
443                (case type
444                  (:tsp-push
445                   (when (eql catch-count 0)
446                     (incf tsp-count count)))
447                  (:tsp-pop
448                   (when (eql catch-count 0)
449                     (decf tsp-count count)))
450                  ((:catch :unwind-protect)
451                   (incf catch-count))
452                  (:throw
453                   (decf catch-count count))))
454              (when (eq next last)
455                (return))
456              (setq next (dll-node-succ next)))))
457        tsp-count))))
458       
459
460(defun dll-to-branch-tree (dll)
461  (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
462         (res (collect-branch-tree (dll-header-first dll) dll hash))
463         (did-something nil))
464    (loop
465      (setq did-something nil)
466      (let ((mapper #'(lambda (key value)
467                        (declare (ignore key))
468                        (flet ((maybe-collect (pc)
469                                 (when (integerp pc)
470                                   (let ((target-tree (gethash pc hash)))
471                                     (if target-tree
472                                       target-tree
473                                       (progn
474                                         (collect-branch-tree (dll-pc->instr dll pc) dll hash)
475                                         (setq did-something t)
476                                         nil))))))
477                          (declare (dynamic-extent #'maybe-collect))
478                          (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
479                            (when target-tree (setf (branch-tree-branch-target value) target-tree)))
480                          (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
481                            (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
482        (declare (dynamic-extent mapper))
483        (maphash mapper hash))
484      (unless did-something (return)))
485    ; To be totally correct, we should fix up the trees containing
486    ; the BLR instruction for unwind-protect cleanups, but none
487    ; of the users of this code yet care that it appears that the code
488    ; stops there.
489    res))
490
491(defun collect-branch-tree (instr dll hash)
492  (unless (eq instr dll)
493    (let ((tree (make-branch-tree :first-instruction instr))
494          (pred nil)
495          (next instr))
496      (setf (gethash (instruction-element-address instr) hash)
497            tree)
498      (loop
499        (when (eq next dll)
500          (setf (branch-tree-last-instruction tree) pred)
501          (return))
502        (multiple-value-bind (type target fall-through) (categorize-instruction next)
503          (case type
504            (:label
505             (when pred
506               (setf (branch-tree-last-instruction tree) pred
507                     (branch-tree-fall-through tree) (instruction-element-address next))
508               (return)))
509            ((:branch :catch :unwind-protect)
510             (setf (branch-tree-last-instruction tree) next
511                   (branch-tree-branch-target tree) target
512                   (branch-tree-fall-through tree) fall-through)
513             (return))))
514        (setq pred next
515              next (dll-node-succ next)))
516      tree)))
517
518;;; Returns 4 values:
519;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
520;;; 2) branch target (or catch or unwind-protect cleanup)
521;;; 3) branch-fallthrough (or catch or unwind-protect body)
522;;; 4) Count for throw, tsp-push, tsp-pop
523#+ppc-target
524(defun categorize-instruction (instr)
525  (etypecase instr
526    (lap-label :label)
527    (lap-instruction
528     (let* ((opcode (lap-instruction-opcode instr))
529            (opcode-p (typep opcode 'opcode))
530            (name (if opcode-p (opcode-name opcode) opcode))
531            (pc (lap-instruction-address instr))
532            (operands (lap-instruction-parsed-operands instr)))
533       (cond ((equalp name "bla")
534              (let ((subprim (car operands)))
535                (case subprim
536                  (.SPmkunwind
537                   (values :unwind-protect (+ pc 4) (+ pc 8)))
538                  ((.SPmkcatch1v .SPmkcatchmv)
539                   (values :catch (+ pc 4) (+ pc 8)))
540                  (.SPthrow
541                   (values :branch nil nil))
542                  ((.SPnthrowvalues .SPnthrow1value)
543                   (let* ((prev-instr (require-type (lap-instruction-pred instr)
544                                                    'lap-instruction))
545                          (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
546                          (prev-operands (lap-instruction-parsed-operands prev-instr)))
547                     ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
548                     ; can't imagine we'll ever see them
549                     (unless (and (equalp prev-name "li")
550                                  (equalp (car prev-operands) "imm0"))
551                       (error "Can't determine throw count for ~s" instr))
552                     (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
553                  ((.SPprogvsave
554                    .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
555                    .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
556                    .SPstkconslist .SPstkconslist-star
557                    .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
558                    .SPstkvcell0 .SPstkvcellvsp
559                    .SPsave-values)
560                   (values :tsp-push nil nil 1))
561                  (.SPrecover-values
562                   (values :tsp-pop nil nil 1))
563                  (t :regular))))
564             ((or (equalp name "lwz") (equalp name "addi"))
565              (if (equalp (car operands) "tsp")
566                (values :tsp-pop nil nil 1)
567                :regular))
568             ((equalp name "stwu")
569              (if (equalp (car operands) "tsp")
570                (values :tsp-push nil nil 1)
571                :regular))
572             ((member name '("ba" "blr" "bctr") :test 'equalp)
573              (values :branch nil nil))
574             ; It would probably be faster to determine the branch address by adding the PC and the offset.
575             ((equalp name "b")
576              (values :branch (branch-label-address instr (car (last operands))) nil))
577             ((and opcode-p (eql (opcode-majorop opcode) 16))
578              (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
579             (t :regular))))))
580
581(defun branch-label-address (instr label-name &aux (next instr))
582  (loop
583    (setq next (dll-node-succ next))
584    (when (eq next instr)
585      (error "Couldn't find label ~s" label-name))
586    (when (and (typep next 'lap-label)
587               (eq (lap-label-name next) label-name))
588      (return (instruction-element-address next)))))
589
590(defun dll-pc->instr (dll pc)
591  (let ((next (dll-node-succ dll)))
592    (loop
593      (when (eq next dll)
594        (error "Couldn't find pc: ~s in ~s" pc dll))
595      (when (eql (instruction-element-address next) pc)
596        (return next))
597      (setq next (dll-node-succ next)))))
598
599)  ; end of #+ppc-target progn
600) ; end of another #+ppc-target progn
601#|
602(setq *save-local-symbols* t)
603
604(defun test (flip flop &optional bar)
605  (let ((another-one t)
606        (bar 'quux))
607    (break)))
608
609(test '(a b c d) #\a)
610
611(defun closure-test (flim flam)
612  (labels ((inner (x)
613              (let ((ret (list x flam)))
614                (break))))
615    (inner flim)
616    (break)))
617
618(closure-test '(a b c) 'quux)
619
620(defun set-test (a b)
621  (break)
622  (+ a b))
623
624(set-test 1 'a)
625
626||#
627
628
629(provide 'backtrace-lds)
630
631; End of backtrace-lds.lisp
Note: See TracBrowser for help on using the repository browser.