|
0
|
1 ;;; -*- Mode: Lisp -*-
|
|
|
2
|
|
|
3 ;;; cmulisp.lisp --
|
|
|
4
|
|
|
5 ;;; This file is part of ILISP.
|
|
|
6 ;;; Version: 5.7
|
|
|
7 ;;;
|
|
|
8 ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
|
|
|
9 ;;; 1993, 1994 Ivan Vasquez
|
|
|
10 ;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker
|
|
|
11 ;;;
|
|
|
12 ;;; Other authors' names for which this Copyright notice also holds
|
|
|
13 ;;; may appear later in this file.
|
|
|
14 ;;;
|
|
|
15 ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
|
|
|
16 ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
|
|
|
17 ;;; mailing list were bugs and improvements are discussed.
|
|
|
18 ;;;
|
|
|
19 ;;; ILISP is freely redistributable under the terms found in the file
|
|
|
20 ;;; COPYING.
|
|
|
21
|
|
|
22
|
|
|
23
|
|
|
24 ;;;
|
|
|
25 ;;; Todd Kaufmann May 1990
|
|
|
26 ;;;
|
|
|
27 ;;; Make CMU CL run better within GNU inferior-lisp (by ccm).
|
|
|
28 ;;;
|
|
|
29
|
|
|
30
|
|
|
31 (in-package "ILISP")
|
|
|
32
|
|
|
33 ;;;% CMU CL does not define defun as a macro
|
|
|
34 (defun ilisp-compile (form package filename)
|
|
|
35 "Compile FORM in PACKAGE recording FILENAME as the source file."
|
|
|
36 (ilisp-errors
|
|
|
37 (ilisp-eval
|
|
|
38 (format nil "(funcall (compile nil '(lambda () ~A)))" form)
|
|
|
39 package filename)))
|
|
|
40
|
|
|
41 ;;;% Stream settings, when running connected to pipes.
|
|
|
42 ;;;
|
|
|
43 ;;; This fixes a problem when running piped: When CMU is running as a piped
|
|
|
44 ;;; process, *terminal-io* really is a terminal; ie, /dev/tty. This means an
|
|
|
45 ;;; error will cause lisp to stop and wait for input from /dev/tty, which it
|
|
|
46 ;;; won't be able to grab, and you'll have to restart your lisp. But we want
|
|
|
47 ;;; it to use the same input that the user is typing in, ie, the pipe (stdin).
|
|
|
48 ;;; This fixes that problem, which only occurs in the CMU cores of this year.
|
|
|
49 ;;;
|
|
|
50
|
|
|
51 (defvar *Fix-pipe-streams* T
|
|
|
52 "Set to Nil if you want them left alone. And tell me you don't get stuck.")
|
|
|
53
|
|
|
54 (when (and *Fix-pipe-streams*
|
|
|
55 (lisp::synonym-stream-p *terminal-io*)
|
|
|
56 (eq (lisp::synonym-stream-symbol *terminal-io*)
|
|
|
57 'SYSTEM::*TTY*))
|
|
|
58 (setf *terminal-io* (make-two-way-stream system::*stdin* system::*stdout*))
|
|
|
59 ;; *query-io* and *debug-io* are synonym streams to this, so this fixes
|
|
|
60 ;; everything.
|
|
|
61 )
|
|
|
62
|
|
|
63 ;;;% Debugger extensions
|
|
|
64
|
|
|
65 ;;;%% Implementation of a :pop command for CMU CL debugger
|
|
|
66
|
|
|
67 ;;;
|
|
|
68 ;;; Normally, errors which occur while in the debugger are just ignored, unless
|
|
|
69 ;;; the user issues the "flush" command, which toggles this behavior.
|
|
|
70 ;;;
|
|
|
71 (setq debug:*flush-debug-errors* nil) ;; allow multiple error levels.
|
|
|
72
|
|
|
73 ;;; This implementation of "POP" simply looks for the first restart that says
|
|
|
74 ;;; "Return to debug level n" or "Return to top level." and executes it.
|
|
|
75 ;;;
|
|
|
76 (debug::def-debug-command "POP" #+:new-compiler ()
|
|
|
77 ;; find the first "Return to ..." restart
|
|
|
78 (if (not (boundp 'debug::*debug-restarts*))
|
|
|
79 (error "You're not in the debugger; how can you call this!?")
|
|
|
80 (labels ((find-return-to (restart-list num)
|
|
|
81 (let ((first
|
|
|
82 (member-if
|
|
|
83 #'(lambda (restart)
|
|
|
84 (string= (funcall
|
|
|
85 (conditions::restart-report-function restart)
|
|
|
86 nil)
|
|
|
87 "Return to " :end1 10))
|
|
|
88 restart-list)))
|
|
|
89 (cond ((zerop num) (car first))
|
|
|
90 ((cdr first) (find-return-to (cdr first) (1- num)))))))
|
|
|
91 (let* ((level (debug::read-if-available 1))
|
|
|
92 (first-return-to (find-return-to
|
|
|
93 debug::*debug-restarts* (1- level))))
|
|
|
94 (if (null first-return-to)
|
|
|
95 (format *debug-io* "pop: ~d is too far" level)
|
|
|
96 (debug::invoke-restart-interactively first-return-to)
|
|
|
97 ))))
|
|
|
98 )
|
|
|
99
|
|
|
100
|
|
|
101 ;;;%% arglist/source-file utils.
|
|
|
102
|
|
|
103 (defun get-correct-fn-object (sym)
|
|
|
104 "Deduce how to get the \"right\" function object and return it."
|
|
|
105 (let ((fun (or (macro-function sym)
|
|
|
106 (and (fboundp sym) (symbol-function sym)))))
|
|
|
107 (cond (fun
|
|
|
108 (when (and (= (lisp::get-type fun) #.vm:closure-header-type)
|
|
|
109 (not (eval:interpreted-function-p fun)))
|
|
|
110 (setq fun (lisp::%closure-function fun)))
|
|
|
111 fun)
|
|
|
112 (t
|
|
|
113 (error "Unknown function ~a. Check package." sym)
|
|
|
114 nil))))
|
|
|
115
|
|
|
116
|
|
|
117
|
|
|
118 (export '(arglist source-file cmulisp-trace))
|
|
|
119
|
|
|
120 ;;;%% arglist - return arglist of function
|
|
|
121
|
|
|
122 (defun arglist (symbol package)
|
|
|
123 (ilisp-errors
|
|
|
124 (let* ((x (ilisp-find-symbol symbol package))
|
|
|
125 (fun (get-correct-fn-object x)))
|
|
|
126 (values
|
|
|
127 (cond ((eval:interpreted-function-p fun)
|
|
|
128 (eval:interpreted-function-arglist fun))
|
|
|
129 ((= (lisp::get-type fun)
|
|
|
130 #.vm:funcallable-instance-header-type)
|
|
|
131 ;; generic function / method
|
|
|
132 (pcl::generic-function-pretty-arglist fun))
|
|
|
133 ((compiled-function-p fun)
|
|
|
134 (let ((string-or-nil
|
|
|
135 (#+CMU17 lisp::%function-arglist
|
|
|
136 #-CMU17 lisp::%function-header-arglist
|
|
|
137 fun)))
|
|
|
138 (if string-or-nil
|
|
|
139 (read-from-string string-or-nil)
|
|
|
140 "No argument info.")))
|
|
|
141 (t (error "Unknown type of function")))))))
|
|
|
142
|
|
|
143
|
|
|
144 ;;; source-file symbol package type --
|
|
|
145 ;;; New version provided by Richard Harris <rharris@chestnut.com> with
|
|
|
146 ;;; suggestions by Larry Hunter <hunter@work.nlm.nih.gov>.
|
|
|
147
|
|
|
148 (defun source-file (symbol package type)
|
|
|
149 (declare (ignore type))
|
|
|
150 (ilisp-errors
|
|
|
151 (let* ((x (ilisp-find-symbol symbol package))
|
|
|
152 (fun (get-correct-fn-object x)))
|
|
|
153 (when (and fun (not (eval:interpreted-function-p fun)))
|
|
|
154 ;; The hack above is necessary because CMUCL does not
|
|
|
155 ;; correctly record source file information when 'loading'
|
|
|
156 ;; a non compiled file.
|
|
|
157 ;; In this case we fall back on the TAGS machinery.
|
|
|
158 ;; (At least as I underestand the code).
|
|
|
159 ;; Marco Antoniotti 11/22/94.
|
|
|
160 (cond (#+CMU17 (pcl::generic-function-p fun)
|
|
|
161 #-CMU17
|
|
|
162 (= (lisp::get-type fun)
|
|
|
163 #.vm:funcallable-instance-header-type)
|
|
|
164 (dolist (method (pcl::generic-function-methods fun))
|
|
|
165 (print-simple-source-info
|
|
|
166 (or #+CMU17
|
|
|
167 (pcl::method-fast-function method)
|
|
|
168 (pcl::method-function method))))
|
|
|
169 t)
|
|
|
170 (t (print-simple-source-info fun)))))))
|
|
|
171
|
|
|
172 ;;; Old version. Left here for the time being.
|
|
|
173 ;(defun source-file (symbol package type)
|
|
|
174 ; (declare (ignore type))
|
|
|
175 ; (ilisp-errors
|
|
|
176 ; (let* ((x (ilisp-find-symbol symbol package))
|
|
|
177 ; (fun (get-correct-fn-object x)))
|
|
|
178 ; (when fun
|
|
|
179 ; (cond ((= (lisp::get-type fun)
|
|
|
180 ; #.vm:funcallable-instance-header-type)
|
|
|
181 ; ;; A PCL method! Uh boy!
|
|
|
182 ; (dolist (method (pcl::generic-function-methods fun))
|
|
|
183 ; (print-simple-source-info
|
|
|
184 ; (lisp::%closure-function (pcl::method-function method))))
|
|
|
185 ; t)
|
|
|
186 ; (t (print-simple-source-info fun)))))))
|
|
|
187
|
|
|
188
|
|
|
189 ;;; Patch suggested by Richard Harris <rharris@chestnut.com>
|
|
|
190
|
|
|
191 ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It
|
|
|
192 ;;; returns a pathname for the file the function was defined in. If it was
|
|
|
193 ;;; not defined in some file, then nil is returned.
|
|
|
194 ;;;
|
|
|
195 ;;; FUN-DEFINED-FROM-PATHNAME is from hemlock/rompsite.lisp (cmucl17f),
|
|
|
196 ;;; with added read-time conditionalization to work in older versions
|
|
|
197 ;;; of cmucl. It may need a little bit more conditionalization for
|
|
|
198 ;;; some older versions of cmucl.
|
|
|
199
|
|
|
200 (defun fun-defined-from-pathname (function)
|
|
|
201 "Returns the file where FUNCTION is defined in (if the file can be found).
|
|
|
202 Takes a symbol or function and returns the pathname for the file the
|
|
|
203 function was defined in. If it was not defined in some file, nil is
|
|
|
204 returned."
|
|
|
205 (flet ((frob (code)
|
|
|
206 (let ((info #+CMU17 (kernel:%code-debug-info code)
|
|
|
207 #-CMU17 (kernel:code-debug-info code)))
|
|
|
208 (when info
|
|
|
209 (let ((sources (c::debug-info-source info)))
|
|
|
210 (when sources
|
|
|
211 (let ((source (car sources)))
|
|
|
212 (when (eq (c::debug-source-from source) :file)
|
|
|
213 (c::debug-source-name source)))))))))
|
|
|
214 (typecase function
|
|
|
215 (symbol (fun-defined-from-pathname (fdefinition function)))
|
|
|
216 #+CMU17
|
|
|
217 (kernel:byte-closure
|
|
|
218 (fun-defined-from-pathname
|
|
|
219 (kernel:byte-closure-function function)))
|
|
|
220 #+CMU17
|
|
|
221 (kernel:byte-function
|
|
|
222 (frob (c::byte-function-component function)))
|
|
|
223 (function
|
|
|
224 (frob (kernel:function-code-header
|
|
|
225 (kernel:%function-self function))))
|
|
|
226 (t nil))))
|
|
|
227
|
|
|
228
|
|
|
229 ;;; print-simple-source-info --
|
|
|
230 ;;; Patches suggested by Larry Hunter <hunter@work.nlm.nih.gov> and
|
|
|
231 ;;; Richard Harris <rharris@chestnut.com>
|
|
|
232 ;;; Nov 21, 1994.
|
|
|
233
|
|
|
234 (defun print-simple-source-info (fun)
|
|
|
235 (let ((path (fun-defined-from-pathname fun)))
|
|
|
236 (when (and path (probe-file path))
|
|
|
237 (print (namestring (truename path)))
|
|
|
238 t)))
|
|
|
239
|
|
|
240
|
|
|
241 ;;; Old version (semi patched). Left here for the time being.
|
|
|
242 ;(defun print-simple-source-info (fun)
|
|
|
243 ; (let ((info (#+CMU17
|
|
|
244 ; kernel:%code-debug-info
|
|
|
245 ; #-CMU17
|
|
|
246 ; kernel:code-debug-info
|
|
|
247 ; (kernel:function-code-header fun))))
|
|
|
248 ; (when info
|
|
|
249 ; (let ((sources (c::compiled-debug-info-source info)))
|
|
|
250 ; (when sources
|
|
|
251 ; (dolist (source sources)
|
|
|
252 ; (let ((name (c::debug-source-name source)))
|
|
|
253 ; (when (eq (c::debug-source-from source) :file)
|
|
|
254 ; ;; Patch suggested by
|
|
|
255 ; ;; hunter@work.nlm.nih.gov (Larry
|
|
|
256 ; ;; Hunter)
|
|
|
257 ; ;; (print (namestring name)) ; old
|
|
|
258 ; (print (truename name))
|
|
|
259 ; )))
|
|
|
260 ; t)))))
|
|
|
261
|
|
|
262
|
|
|
263 (defun cmulisp-trace (symbol package breakp)
|
|
|
264 "Trace SYMBOL in PACKAGE."
|
|
|
265 (ilisp-errors
|
|
|
266 (let ((real-symbol (ilisp-find-symbol symbol package)))
|
|
|
267 (setq breakp (read-from-string breakp))
|
|
|
268 (when real-symbol (eval `(trace ,real-symbol :break ,breakp))))))
|
