source: branches/1.1/ccl/lib/backtrace-lds.lisp @ 8618

Last change on this file since 8618 was 8618, checked in by gb, 14 years ago

FRAME-SUPPLIED-ARGS: be a little more defensive.

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