Mercurial > hg > xemacs-beta

comparison lisp/ilisp/cmulisp.lisp @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children b82b59fe008d
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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))))))