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

Last change on this file since 16685 was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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  #+(or x8632-target arm-target) 0
25  #+x8664-target 4
26  #+ppc-target 8)
27
28(defparameter *saved-register-names*
29  #+(or x8632-target arm-target) nil
30  #+x8664-target #(save3 save2 save1 save0)
31  #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0))
32
33(defun frame-function (frame context)
34  "Returns the function using the frame, and pc offset within the function, if known"
35  (declare (ignore context))
36  (cfp-lfun frame))
37
38(defun frame-supplied-arguments (frame context &key (unknown-marker (%unbound-marker)))
39  "Return a list of supplied arguments to the call which opened this frame, as best we can reconstruct it"
40  (multiple-value-bind (lfun pc) (cfp-lfun frame)
41    (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc)
42      (if (not valid)
43        unknown-marker
44        (if (eq unknown-marker (%unbound-marker))
45          args
46          (substitute unknown-marker (%unbound-marker) args))))))
47
48(defun frame-named-variables (frame context &key (unknown-marker (%unbound-marker)))
49  "Returns an alist of (NAME . VALUE) of all named variables in this frame."
50  (multiple-value-bind (lfun pc) (cfp-lfun frame)
51    (multiple-value-bind (args locals) (arguments-and-locals context frame lfun pc unknown-marker)
52      (if (eq unknown-marker (%unbound-marker))
53        (append args locals)
54        (substitute unknown-marker (%unbound-marker) (append args locals))))))
55
56
57(defun frame-arguments-and-locals (frame context &key unknown-marker)
58  "Return two values, the arguments and the locals, known for this frame, as alists of (name . value)"
59  (multiple-value-bind (lfun pc) (cfp-lfun frame)
60    (arguments-and-locals context frame lfun pc unknown-marker)))
61
62;;; Returns three values: (ARG-VALUES TYPES NAMES), solely for the benefit
63;;; of the FRAME-ARGUMENTS function in SLIME's swank-openmcl.lisp.
64;;; ARG-VALUES is a list of the values of the args supplied to the function
65;;; TYPES is a list of (for bad historical reasons) strings .describing
66;;;   whether they're "required", "optional", etc.  SLIME only really
67;;;   cares about whether this is equal to "keyword" or not.
68;;; NAMES is a list of symbols which name the args.
69;; 7/13/2009: This is now deprecated.  Use frame-supplied-arguments.
70(defun frame-supplied-args (frame lfun pc child context)
71  (declare (ignore child))
72  (if (null pc)
73    (values nil nil nil)
74    (if (<= pc target::arg-check-trap-pc-limit)
75      (values (arg-check-call-arguments frame lfun) nil nil)
76      (multiple-value-bind (arglist valid) (arglist-from-map lfun)
77        (if (not valid)
78          (values nil nil nil)
79          (let* ((args (arguments-and-locals context frame lfun pc))
80                 (state :required))
81            (collect ((arg-values)
82                      (types)
83                      (names))
84              (dolist (arg arglist)
85                (if (or (member arg lambda-list-keywords)
86                        (eq arg '&lexpr))
87                  (setq state arg)
88                  (let* ((pair (pop args)))
89                    (case state
90                      (&lexpr
91                         (with-list-from-lexpr (rest (cdr pair))
92                           (dolist (r rest) (arg-values r) (names nil) (types nil)))
93                         (return))
94                      (&rest
95                         (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
96                         (return))
97                      (&key
98                         (arg-values arg)
99                         (names nil)
100                         (types nil)))
101                    (let* ((value (cdr pair)))
102                      (if (eq value (%unbound-marker))
103                        (return))
104                      (names (car pair))
105                      (arg-values value)
106                      (types nil)))))
107              (values (arg-values) (types) (names)))))))))
108
109
110#|
111(setq *save-local-symbols* t)
112
113(defun test (flip flop &optional bar)
114  (let ((another-one t)
115        (bar 'quux))
116    (break)))
117
118(test '(a b c d) #\a)
119
120(defun closure-test (flim flam)
121  (labels ((inner (x)
122              (let ((ret (list x flam)))
123                (break))))
124    (inner flim)
125    (break)))
126
127(closure-test '(a b c) 'quux)
128
129(defun set-test (a b)
130  (break)
131  (+ a b))
132
133(set-test 1 'a)
134
135||#
136
137
138(provide 'backtrace-lds)
139
140; End of backtrace-lds.lisp
Note: See TracBrowser for help on using the repository browser.