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