source: trunk/source/lib/backtrace-lds.lisp @ 14119

Last change on this file since 14119 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;;; backtrace-lds.lisp
19;;; low-level support for stack-backtrace dialog (Lisp Development System)
20
21(in-package "CCL")
22
23
24(defparameter *saved-register-count*
25  #+(or x8632-target arm-target) 0
26  #+x8664-target 4
27  #+ppc-target 8)
28
29(defparameter *saved-register-names*
30  #+(or x8632-target arm-target) nil
31  #+x8664-target #(save3 save2 save1 save0)
32  #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0))
33
34(defun frame-function (frame context)
35  "Returns the function using the frame, and pc offset within the function, if known"
36  (declare (ignore context))
37  (cfp-lfun (require-type frame 'integer)))
38
39(defun frame-supplied-arguments (frame context &key (unknown-marker (%unbound-marker)))
40  "Return a list of supplied arguments to the call which opened this frame, as best we can reconstruct it"
41  (multiple-value-bind (lfun pc) (cfp-lfun frame)
42    (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc)
43      (if (not valid)
44        unknown-marker
45        (if (eq unknown-marker (%unbound-marker))
46          args
47          (substitute unknown-marker (%unbound-marker) args))))))
48
49(defun frame-named-variables (frame context &key (unknown-marker (%unbound-marker)))
50  "Returns an alist of (NAME . VALUE) of all named variables in this frame."
51  (multiple-value-bind (lfun pc) (cfp-lfun frame)
52    (multiple-value-bind (args locals) (arguments-and-locals context frame lfun pc unknown-marker)
53      (if (eq unknown-marker (%unbound-marker))
54        (append args locals)
55        (substitute unknown-marker (%unbound-marker) (append args locals))))))
56
57
58(defun frame-arguments-and-locals (frame context &key unknown-marker)
59  "Return two values, the arguments and the locals, known for this frame, as alists of (name . value)"
60  (multiple-value-bind (lfun pc) (cfp-lfun frame)
61    (arguments-and-locals context frame lfun pc unknown-marker)))
62
63;;; Returns three values: (ARG-VALUES TYPES NAMES), solely for the benefit
64;;; of the FRAME-ARGUMENTS function in SLIME's swank-openmcl.lisp.
65;;; ARG-VALUES is a list of the values of the args supplied to the function
66;;; TYPES is a list of (for bad historical reasons) strings .describing
67;;;   whether they're "required", "optional", etc.  SLIME only really
68;;;   cares about whether this is equal to "keyword" or not.
69;;; NAMES is a list of symbols which name the args.
70;; 7/13/2009: This is now deprecated.  Use frame-supplied-arguments.
71(defun frame-supplied-args (frame lfun pc child context)
72  (declare (ignore child))
73  (if (null pc)
74    (values nil nil nil)
75    (if (<= pc target::arg-check-trap-pc-limit)
76      (values (arg-check-call-arguments frame lfun) nil nil)
77      (multiple-value-bind (arglist valid) (arglist-from-map lfun)
78        (if (not valid)
79          (values nil nil nil)
80          (let* ((args (arguments-and-locals context frame lfun pc))
81                 (state :required))
82            (collect ((arg-values)
83                      (types)
84                      (names))
85              (dolist (arg arglist)
86                (if (or (member arg lambda-list-keywords)
87                        (eq arg '&lexpr))
88                  (setq state arg)
89                  (let* ((pair (pop args)))
90                    (case state
91                      (&lexpr
92                         (with-list-from-lexpr (rest (cdr pair))
93                           (dolist (r rest) (arg-values r) (names nil) (types nil)))
94                         (return))
95                      (&rest
96                         (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
97                         (return))
98                      (&key
99                         (arg-values arg)
100                         (names nil)
101                         (types nil)))
102                    (let* ((value (cdr pair)))
103                      (if (eq value (%unbound-marker))
104                        (return))
105                      (names (car pair))
106                      (arg-values value)
107                      (types nil)))))
108              (values (arg-values) (types) (names)))))))))
109
110
111#|
112(setq *save-local-symbols* t)
113
114(defun test (flip flop &optional bar)
115  (let ((another-one t)
116        (bar 'quux))
117    (break)))
118
119(test '(a b c d) #\a)
120
121(defun closure-test (flim flam)
122  (labels ((inner (x)
123              (let ((ret (list x flam)))
124                (break))))
125    (inner flim)
126    (break)))
127
128(closure-test '(a b c) 'quux)
129
130(defun set-test (a b)
131  (break)
132  (+ a b))
133
134(set-test 1 'a)
135
136||#
137
138
139(provide 'backtrace-lds)
140
141; End of backtrace-lds.lisp
Note: See TracBrowser for help on using the repository browser.