/[slime]/slime/swank-clisp.lisp
ViewVC logotype

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.66 - (hide annotations)
Sat Feb 9 18:38:58 2008 UTC (6 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.65: +1 -1 lines
Inspector cleanups.

* swank.lisp (emacs-inspect): Renamed from inspect-for-emacs.
Changed all method-defs acordingly.
(common-seperated-spec, inspector-princ): Moved to
swank-fancy-inspector.lisp.
(inspector-content): Renamed from inspector-content-for-emacs.
(value-part): Renamed from value-part-for-emacs.
(action-part): Renamed from action-part-for-emacs.
(inspect-list): Renamed from inspect-for-emacs-list.
(inspect-list-aux): New.
(inspect-cons): Renamed from inspect-for-emacs-simple-cons.
(*inspect-length*): Deleted.
(inspect-list): Ignore max-length stuff.
(inspector-content): Don't allow nil elements.
(emacs-inspect array): Make the label of element type more
consistent with the others.
1 mbaringer 1.63 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
2    
3 heller 1.1 ;;;; SWANK support for CLISP.
4    
5 vsedach 1.3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
6 heller 1.1
7 wjenkner 1.54 ;;;; This program is free software; you can redistribute it and/or
8 heller 1.1 ;;;; modify it under the terms of the GNU General Public License as
9 wjenkner 1.54 ;;;; published by the Free Software Foundation; either version 2 of
10     ;;;; the License, or (at your option) any later version.
11    
12     ;;;; This program is distributed in the hope that it will be useful,
13     ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14     ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15     ;;;; GNU General Public License for more details.
16    
17     ;;;; You should have received a copy of the GNU General Public
18     ;;;; License along with this program; if not, write to the Free
19     ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20     ;;;; MA 02111-1307, USA.
21 heller 1.1
22     ;;; This is work in progress, but it's already usable. Many things
23     ;;; are adapted from other swank-*.lisp, in particular from
24     ;;; swank-allegro (I don't use allegro at all, but it's the shortest
25     ;;; one and I found Helmut Eller's code there enlightening).
26    
27 wjenkner 1.54 ;;; This code will work better with recent versions of CLISP (say, the
28     ;;; last release or CVS HEAD) while it may not work at all with older
29     ;;; versions. It is reasonable to expect it to work on platforms with
30     ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
31     ;;; systems, but also on Win32. This backend uses the portable xref
32     ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
33     ;;; are conveniently included in SLIME.
34    
35 heller 1.20 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
36 heller 1.1
37 heller 1.25 (in-package :swank-backend)
38 heller 1.1
39     (eval-when (:compile-toplevel :load-toplevel :execute)
40 heller 1.33 ;;(use-package "SOCKET")
41 heller 1.1 (use-package "GRAY"))
42    
43 heller 1.49 ;;;; if this lisp has the complete CLOS then we use it, otherwise we
44     ;;;; build up a "fake" swank-mop and then override the methods in the
45 mbaringer 1.36 ;;;; inspector.
46    
47     (eval-when (:compile-toplevel :load-toplevel :execute)
48     (defvar *have-mop*
49 mbaringer 1.37 (and (find-package :clos)
50     (eql :external
51 heller 1.44 (nth-value 1 (find-symbol (string ':standard-slot-definition)
52 mbaringer 1.63 :clos))))
53 heller 1.49 "True in those CLISP images which have a complete MOP implementation."))
54 mbaringer 1.37
55     #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
56     (progn
57 heller 1.44 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
58 mbaringer 1.63
59 mbaringer 1.37 (defun swank-mop:slot-definition-documentation (slot)
60     (clos::slot-definition-documentation slot)))
61 mbaringer 1.35
62 mbaringer 1.37 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
63 mbaringer 1.36 (defclass swank-mop:standard-slot-definition ()
64     ()
65 mbaringer 1.63 (:documentation
66 heller 1.44 "Dummy class created so that swank.lisp will compile and load."))
67 mbaringer 1.36
68 wjenkner 1.54 ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
69     ;; (progn
70     ;; (defmacro with-blocked-signals ((&rest signals) &body body)
71     ;; (ext:with-gensyms ("SIGPROCMASK" ret mask)
72     ;; `(multiple-value-bind (,ret ,mask)
73 mbaringer 1.63 ;; (linux:sigprocmask-set-n-save
74     ;; ,linux:SIG_BLOCK
75     ;; ,(do ((sigset (linux:sigset-empty)
76     ;; (linux:sigset-add sigset (the fixnum (pop signals)))))
77     ;; ((null signals) sigset)))
78     ;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
79     ;; (unwind-protect
80     ;; (progn ,@body)
81     ;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
82 wjenkner 1.54
83     ;; (defimplementation call-without-interrupts (fn)
84     ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
85    
86     ;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and))
87 heller 1.27 (defimplementation call-without-interrupts (fn)
88 heller 1.12 (funcall fn))
89 vsedach 1.3
90 heller 1.49 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
91 mbaringer 1.63 ;; old name prior to 2005-03-01, clisp <= 2.33.2
92     (find-symbol "PROGRAM-ID" :system)
93     #+win32 ; integrated into the above since 2005-02-24
94     (and (find-package :win32) ; optional modules/win32
95     (find-symbol "GetCurrentProcessId" :win32)))))
96 heller 1.49 (defimplementation getpid () ; a required interface
97     (cond
98     (getpid (funcall getpid))
99     #+win32 ((ext:getenv "PID")) ; where does that come from?
100     (t -1))))
101 heller 1.1
102 heller 1.21 (defimplementation lisp-implementation-type-name ()
103     "clisp")
104    
105 heller 1.28 (defimplementation set-default-directory (directory)
106     (setf (ext:default-directory) directory)
107     (namestring (setf *default-pathname-defaults* (ext:default-directory))))
108    
109 mbaringer 1.63 ;;;; TCP Server
110 heller 1.1
111 heller 1.17 (defimplementation create-socket (host port)
112     (declare (ignore host))
113 heller 1.8 (socket:socket-server port))
114 lgorrie 1.7
115 wjenkner 1.14 (defimplementation local-port (socket)
116 heller 1.8 (socket:socket-server-port socket))
117 vsedach 1.5
118 wjenkner 1.14 (defimplementation close-socket (socket)
119 heller 1.8 (socket:socket-server-close socket))
120 mbaringer 1.63
121 heller 1.43 (defimplementation accept-connection (socket
122 mbaringer 1.63 &key external-format buffering timeout)
123 dcrosher 1.58 (declare (ignore buffering timeout))
124 heller 1.8 (socket:socket-accept socket
125 mbaringer 1.63 :buffered nil ;; XXX should be t
126     :element-type 'character
127     :external-format external-format))
128 heller 1.60
129 mbaringer 1.63 ;;;; Coding systems
130 heller 1.60
131     (defvar *external-format-to-coding-system*
132 mbaringer 1.63 '(((:charset "iso-8859-1" :line-terminator :unix)
133 heller 1.60 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
134 mbaringer 1.63 ((:charset "iso-8859-1":latin-1)
135 heller 1.60 "latin-1" "iso-latin-1" "iso-8859-1")
136     ((:charset "utf-8") "utf-8")
137     ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
138     ((:charset "euc-jp") "euc-jp")
139     ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
140     ((:charset "us-ascii") "us-ascii")
141     ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
142    
143     (defimplementation find-external-format (coding-system)
144 mbaringer 1.63 (let ((args (car (rassoc-if (lambda (x)
145     (member coding-system x :test #'equal))
146     *external-format-to-coding-system*))))
147 heller 1.60 (and args (apply #'ext:make-encoding args))))
148    
149 vsedach 1.3
150 mbaringer 1.63 ;;;; Swank functions
151 heller 1.1
152 heller 1.25 (defimplementation arglist (fname)
153 heller 1.30 (block nil
154 heller 1.56 (or (ignore-errors
155 mbaringer 1.63 (let ((exp (function-lambda-expression fname)))
156     (and exp (return (second exp)))))
157     (ignore-errors
158     (return (ext:arglist fname)))
159     :not-available)))
160 heller 1.1
161 wjenkner 1.14 (defimplementation macroexpand-all (form)
162 heller 1.1 (ext:expand-form form))
163    
164 wjenkner 1.14 (defimplementation describe-symbol-for-emacs (symbol)
165 heller 1.1 "Return a plist describing SYMBOL.
166     Return NIL if the symbol is unbound."
167     (let ((result ()))
168 heller 1.47 (flet ((doc (kind)
169 mbaringer 1.63 (or (documentation symbol kind) :not-documented))
170     (maybe-push (property value)
171     (when value
172     (setf result (list* property value result)))))
173 heller 1.47 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
174 heller 1.1 (when (fboundp symbol)
175 mbaringer 1.63 (maybe-push
176     ;; Report WHEN etc. as macros, even though they may be
177     ;; implemented as special operators.
178     (if (macro-function symbol) :macro
179     (typecase (fdefinition symbol)
180     (generic-function :generic-function)
181     (function :function)
182     ;; (type-of 'progn) -> ext:special-operator
183     (t :special-operator)))
184     (doc 'function)))
185 heller 1.50 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
186 mbaringer 1.63 (get symbol 'system::setf-expander)); defsetf
187     (maybe-push :setf (doc 'setf)))
188 heller 1.50 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
189 mbaringer 1.63 (get symbol 'system::defstruct-description)
190     (get symbol 'system::deftype-expander))
191     (maybe-push :type (doc 'type))) ; even for 'structure
192 heller 1.50 (when (find-class symbol nil)
193 mbaringer 1.63 (maybe-push :class (doc 'type)))
194 heller 1.48 ;; Let this code work compiled in images without FFI
195     (let ((types (load-time-value
196 mbaringer 1.63 (and (find-package "FFI")
197     (symbol-value
198     (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
199     ;; Use ffi::*c-type-table* so as not to suffer the overhead of
200     ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
201     ;; which are not FFI type names.
202     (when (and types (nth-value 1 (gethash symbol types)))
203     ;; Maybe use (case (head (ffi:deparse-c-type)))
204     ;; to distinguish struct and union types?
205     (maybe-push :alien-type :not-documented)))
206 heller 1.1 result)))
207    
208 heller 1.25 (defimplementation describe-definition (symbol namespace)
209     (ecase namespace
210     (:variable (describe symbol))
211     (:macro (describe (macro-function symbol)))
212     (:function (describe (symbol-function symbol)))
213     (:class (describe (find-class symbol)))))
214    
215 heller 1.26 (defun fspec-pathname (symbol)
216 wjenkner 1.54 (let ((path (documentation symbol 'sys::file))
217 mbaringer 1.63 lines)
218 wjenkner 1.54 (when (consp path)
219     (psetq path (car path)
220 mbaringer 1.63 lines (cdr path)))
221 wjenkner 1.54 (when (and path
222 mbaringer 1.63 (member (pathname-type path)
223     custom:*compiled-file-types* :test #'equal))
224 wjenkner 1.54 (setq path
225 mbaringer 1.63 (loop for suffix in custom:*source-file-types*
226     thereis (probe-file (make-pathname :defaults path
227     :type suffix)))))
228 wjenkner 1.54 (values path lines)))
229 heller 1.1
230 heller 1.26 (defun fspec-location (fspec)
231 wjenkner 1.54 (multiple-value-bind (file lines)
232     (fspec-pathname fspec)
233 heller 1.26 (cond (file
234 mbaringer 1.63 (multiple-value-bind (truename c) (ignore-errors (truename file))
235     (cond (truename
236     (make-location (list :file (namestring truename))
237     (if (consp lines)
238     (list* :line lines)
239     (list :function-name (string fspec)))))
240     (t (list :error (princ-to-string c))))))
241     (t (list :error (format nil "No source information available for: ~S"
242     fspec))))))
243 heller 1.25
244     (defimplementation find-definitions (name)
245 heller 1.26 (list (list name (fspec-location name))))
246 heller 1.1
247 heller 1.56 (defun trim-whitespace (string)
248     (string-trim #(#\newline #\space #\tab) string))
249 heller 1.1
250 heller 1.56 (defvar *sldb-backtrace*)
251 heller 1.30
252 wjenkner 1.14 (defimplementation call-with-debugging-environment (debugger-loop-fn)
253 heller 1.57 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
254 mbaringer 1.63 ;;(sys::*driver* debugger-loop-fn)
255     ;;(sys::*fasoutput-stream* nil)
256     (*sldb-backtrace*
257     (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
258 heller 1.1 (funcall debugger-loop-fn)))
259    
260 mbaringer 1.63 (defun nth-frame (index)
261 heller 1.56 (nth index *sldb-backtrace*))
262    
263     (defun sldb-backtrace ()
264     "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
265 heller 1.62 (do ((frames '())
266 heller 1.56 (last nil frame)
267 heller 1.62 (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames"
268     ((eq frame last) (nreverse frames))
269     (unless (boring-frame-p frame)
270     (push frame frames))))
271    
272     (defun boring-frame-p (frame)
273     (member (frame-type frame) '(stack-value bind-var bind-env)))
274    
275     (defun frame-to-string (frame)
276 mbaringer 1.63 (with-output-to-string (s)
277 heller 1.62 (sys::describe-frame s frame)))
278    
279     (defun frame-type (frame)
280     ;; FIXME: should bind *print-length* etc. to small values.
281     (frame-string-type (frame-to-string frame)))
282    
283     (defvar *frame-prefixes*
284     '(("frame binding variables" bind-var)
285     ("<1> #<compiled-function" compiled-fun)
286     ("<1> #<system-function" sys-fun)
287     ("<1> #<special-operator" special-op)
288     ("EVAL frame" eval)
289     ("APPLY frame" apply)
290     ("compiled tagbody frame" compiled-tagbody)
291     ("compiled block frame" compiled-block)
292     ("block frame" block)
293     ("nested block frame" block)
294     ("tagbody frame" tagbody)
295     ("nested tagbody frame" tagbody)
296     ("catch frame" catch)
297     ("handler frame" handler)
298     ("unwind-protect frame" unwind-protect)
299     ("driver frame" driver)
300     ("frame binding environments" bind-env)
301     ("CALLBACK frame" callback)
302     ("- " stack-value)
303     ("<1> " fun)
304     ("<2> " 2nd-frame)))
305    
306     (defun frame-string-type (string)
307     (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
308 mbaringer 1.63 *frame-prefixes*)))
309 heller 1.1
310 heller 1.25 (defimplementation compute-backtrace (start end)
311 heller 1.56 (let* ((bt *sldb-backtrace*)
312 mbaringer 1.63 (len (length bt)))
313 heller 1.56 (subseq bt start (min (or end len) len))))
314 heller 1.1
315 mbaringer 1.63 ;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we
316     ;;; can omit that restart so that users don't select it by mistake.
317     (defimplementation compute-sane-restarts (condition)
318     ;; The outermost restart is specified to be the last element of the
319     ;; list, hopefully that's our unwanted ABORT restart.
320     (butlast (compute-restarts condition)))
321    
322 heller 1.25 (defimplementation print-frame (frame stream)
323 heller 1.62 (let ((str (frame-to-string frame)))
324 mbaringer 1.63 ;; (format stream "~A " (frame-string-type str))
325     (write-string (extract-frame-line str)
326     stream)))
327 heller 1.56
328 heller 1.62 (defun extract-frame-line (frame-string)
329     (let ((s frame-string))
330     (trim-whitespace
331     (case (frame-string-type s)
332     ((eval special-op)
333 mbaringer 1.63 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
334 heller 1.62 (apply
335 mbaringer 1.63 (string-match "APPLY frame for call \\(.*\\)" s 1))
336 heller 1.62 ((compiled-fun sys-fun fun)
337 mbaringer 1.63 (extract-function-name s))
338 heller 1.62 (t s)))))
339    
340     (defun extract-function-name (string)
341     (let ((1st (car (split-frame-string string))))
342     (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
343 mbaringer 1.63 1st
344     1)
345     (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
346     1st)))
347 heller 1.62
348     (defun split-frame-string (string)
349 mbaringer 1.63 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
350     (mapcar #'car *frame-prefixes*))))
351 heller 1.62 (loop for pos = 0 then (1+ (regexp:match-start match))
352 mbaringer 1.63 for match = (regexp:match rx string :start pos)
353     if match collect (subseq string pos (regexp:match-start match))
354     else collect (subseq string pos)
355     while match)))
356 heller 1.62
357     (defun string-match (pattern string n)
358     (let* ((match (nth-value n (regexp:match pattern string))))
359     (if match (regexp:match-string string match))))
360    
361 heller 1.56 (defimplementation format-sldb-condition (condition)
362     (trim-whitespace (princ-to-string condition)))
363 heller 1.1
364 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
365 heller 1.62 (sys::eval-at (nth-frame frame-number) form))
366 heller 1.1
367 mbaringer 1.63 (defimplementation frame-locals (frame-number)
368 heller 1.62 (let ((frame (nth-frame frame-number)))
369     (loop for i below (%frame-count-vars frame)
370 mbaringer 1.63 collect (list :name (%frame-var-name frame i)
371     :value (%frame-var-value frame i)
372     :id 0))))
373 heller 1.33
374 heller 1.62 (defimplementation frame-var-value (frame var)
375     (%frame-var-value (nth-frame frame) var))
376 heller 1.1
377 mbaringer 1.63 ;;; Interpreter-Variablen-Environment has the shape
378     ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
379 heller 1.1
380 heller 1.62 (defun %frame-count-vars (frame)
381     (cond ((sys::eval-frame-p frame)
382 mbaringer 1.63 (do ((venv (frame-venv frame) (next-venv venv))
383     (count 0 (+ count (/ (1- (length venv)) 2))))
384     ((not venv) count)))
385     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
386     (length (%parse-stack-values frame)))
387     (t 0)))
388 heller 1.62
389     (defun %frame-var-name (frame i)
390     (cond ((sys::eval-frame-p frame)
391 mbaringer 1.63 (nth-value 0 (venv-ref (frame-venv frame) i)))
392     (t (format nil "~D" i))))
393 heller 1.62
394     (defun %frame-var-value (frame i)
395     (cond ((sys::eval-frame-p frame)
396 mbaringer 1.63 (let ((name (venv-ref (frame-venv frame) i)))
397     (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
398     (if c
399     (format-sldb-condition c)
400     v))))
401     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
402     (let ((str (nth i (%parse-stack-values frame))))
403     (trim-whitespace (subseq str 2))))
404     (t (break "Not implemented"))))
405 heller 1.62
406     (defun frame-venv (frame)
407     (let ((env (sys::eval-at frame '(sys::the-environment))))
408     (svref env 0)))
409    
410     (defun next-venv (venv) (svref venv (1- (length venv))))
411    
412     (defun venv-ref (env i)
413     "Reference the Ith binding in ENV.
414     Return two values: NAME and VALUE"
415     (let ((idx (* i 2)))
416     (if (< idx (1- (length env)))
417 mbaringer 1.63 (values (svref env idx) (svref env (1+ idx)))
418     (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
419 heller 1.62
420     (defun %parse-stack-values (frame)
421     (labels ((next (fp) (sys::frame-down-1 fp 1))
422 mbaringer 1.63 (parse (fp accu)
423     (let ((str (frame-to-string fp)))
424     (cond ((is-prefix-p "- " str)
425     (parse (next fp) (cons str accu)))
426     ((is-prefix-p "<1> " str)
427     ;;(when (eq (frame-type frame) 'compiled-fun)
428     ;; (pop accu))
429     (dolist (str (cdr (split-frame-string str)))
430     (when (is-prefix-p "- " str)
431     (push str accu)))
432     (nreverse accu))
433     (t (parse (next fp) accu))))))
434 heller 1.62 (parse (next frame) '())))
435    
436     (defun is-prefix-p (pattern string)
437     (not (mismatch pattern string :end2 (min (length pattern)
438 mbaringer 1.63 (length string)))))
439 heller 1.1
440 wjenkner 1.14 (defimplementation frame-catch-tags (index)
441 heller 1.1 (declare (ignore index))
442     nil)
443    
444 wjenkner 1.14 (defimplementation return-from-frame (index form)
445 heller 1.62 (sys::return-from-eval-frame (nth-frame index) form))
446 wjenkner 1.14
447     (defimplementation restart-frame (index)
448 heller 1.62 (sys::redo-eval-frame (nth-frame index)))
449 wjenkner 1.14
450     (defimplementation frame-source-location-for-emacs (index)
451 mbaringer 1.63 `(:error
452     ,(format nil "frame-source-location not implemented. (frame: ~A)"
453     (nth-frame index))))
454 heller 1.1
455 mbaringer 1.63 ;;;; Profiling
456 wjenkner 1.16
457     (defimplementation profile (fname)
458 mbaringer 1.63 (eval `(mon:monitor ,fname))) ;monitor is a macro
459 wjenkner 1.16
460     (defimplementation profiled-functions ()
461     mon:*monitored-functions*)
462    
463     (defimplementation unprofile (fname)
464 mbaringer 1.63 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
465 wjenkner 1.16
466     (defimplementation unprofile-all ()
467     (mon:unmonitor))
468    
469     (defimplementation profile-report ()
470     (mon:report-monitoring))
471    
472     (defimplementation profile-reset ()
473     (mon:reset-all-monitoring))
474    
475     (defimplementation profile-package (package callers-p methods)
476     (declare (ignore callers-p methods))
477     (mon:monitor-all package))
478 heller 1.1
479 mbaringer 1.63 ;;;; Handle compiler conditions (find out location of error etc.)
480 heller 1.1
481     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
482     "Pass ARGS to COMPILE-FILE, send the compiler notes to
483     *STANDARD-INPUT* and frob them in BODY."
484     `(let ((*error-output* (make-string-output-stream))
485 mbaringer 1.63 (*compile-verbose* t))
486 heller 1.1 (multiple-value-prog1
487 vsedach 1.6 (compile-file ,@args)
488 mbaringer 1.63 (handler-case
489 heller 1.1 (with-input-from-string
490 mbaringer 1.63 (*standard-input* (get-output-stream-string *error-output*))
491     ,@body)
492 vsedach 1.6 (sys::simple-end-of-file () nil)))))
493 heller 1.1
494 heller 1.25 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
495     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
496     (defvar *orig-c-error* (symbol-function 'system::c-error))
497     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
498    
499     (defmacro dynamic-flet (names-functions &body body)
500     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
501 heller 1.46 Execute BODY with NAME's function slot set to FUNCTION."
502 heller 1.25 `(ext:letf* ,(loop for (name function) in names-functions
503 mbaringer 1.63 collect `((symbol-function ',name) ,function))
504 heller 1.25 ,@body))
505 heller 1.45
506     (defvar *buffer-name* nil)
507     (defvar *buffer-offset*)
508    
509 heller 1.25 (defun compiler-note-location ()
510 heller 1.27 "Return the current compiler location."
511 heller 1.25 (let ((lineno1 sys::*compile-file-lineno1*)
512 mbaringer 1.63 (lineno2 sys::*compile-file-lineno2*)
513     (file sys::*compile-file-truename*))
514 heller 1.25 (cond ((and file lineno1 lineno2)
515 mbaringer 1.63 (make-location (list ':file (namestring file))
516     (list ':line lineno1)))
517     (*buffer-name*
518     (make-location (list ':buffer *buffer-name*)
519     (list ':position *buffer-offset*)))
520     (t
521     (list :error "No error location available")))))
522 heller 1.25
523     (defun signal-compiler-warning (cstring args severity orig-fn)
524     (signal (make-condition 'compiler-condition
525 mbaringer 1.63 :severity severity
526     :message (apply #'format nil cstring args)
527     :location (compiler-note-location)))
528 heller 1.25 (apply orig-fn cstring args))
529    
530     (defun c-warn (cstring &rest args)
531     (signal-compiler-warning cstring args :warning *orig-c-warn*))
532    
533     (defun c-style-warn (cstring &rest args)
534     (dynamic-flet ((sys::c-warn *orig-c-warn*))
535     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
536    
537     (defun c-error (cstring &rest args)
538     (signal-compiler-warning cstring args :error *orig-c-error*))
539    
540 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
541 heller 1.25 (handler-bind ((warning #'handle-notification-condition))
542     (dynamic-flet ((system::c-warn #'c-warn)
543 mbaringer 1.63 (system::c-style-warn #'c-style-warn)
544     (system::c-error #'c-error))
545 heller 1.25 (funcall function))))
546 heller 1.1
547     (defun handle-notification-condition (condition)
548     "Handle a condition caused by a compiler warning."
549 heller 1.25 (signal (make-condition 'compiler-condition
550 mbaringer 1.63 :original-condition condition
551     :severity :warning
552     :message (princ-to-string condition)
553     :location (compiler-note-location))))
554 heller 1.1
555 heller 1.60 (defimplementation swank-compile-file (filename load-p external-format)
556     (with-compilation-hooks ()
557     (with-compilation-unit ()
558 mbaringer 1.63 (let ((fasl-file (compile-file filename
559     :external-format external-format)))
560     (when (and load-p fasl-file)
561     (load fasl-file))
562     nil))))
563 heller 1.1
564 pseibel 1.34 (defimplementation swank-compile-string (string &key buffer position directory)
565     (declare (ignore directory))
566 heller 1.1 (with-compilation-hooks ()
567 heller 1.25 (let ((*buffer-name* buffer)
568 mbaringer 1.63 (*buffer-offset* position))
569 heller 1.25 (funcall (compile nil (read-from-string
570 heller 1.27 (format nil "(~S () ~A)" 'lambda string)))))))
571 heller 1.1
572 mbaringer 1.63 ;;;; Portable XREF from the CMU AI repository.
573 heller 1.1
574 lgorrie 1.32 (setq pxref::*handle-package-forms* '(cl:in-package))
575 heller 1.1
576 heller 1.25 (defmacro defxref (name function)
577     `(defimplementation ,name (name)
578     (xref-results (,function name))))
579    
580 lgorrie 1.32 (defxref who-calls pxref:list-callers)
581     (defxref who-references pxref:list-readers)
582     (defxref who-binds pxref:list-setters)
583     (defxref who-sets pxref:list-setters)
584     (defxref list-callers pxref:list-callers)
585     (defxref list-callees pxref:list-callees)
586 heller 1.1
587 heller 1.28 (defun xref-results (symbols)
588 heller 1.1 (let ((xrefs '()))
589 heller 1.28 (dolist (symbol symbols)
590     (push (list symbol (fspec-location symbol)) xrefs))
591 heller 1.25 xrefs))
592 heller 1.1
593     (when (find-package :swank-loader)
594     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
595 mbaringer 1.63 (lambda ()
596     (let ((home (user-homedir-pathname)))
597     (and (ext:probe-directory home)
598     (probe-file (format nil "~A/.swank.lisp"
599     (namestring (truename home)))))))))
600 heller 1.1
601 mbaringer 1.63 ;;; Don't set *debugger-hook* to nil on break.
602     (ext:without-package-lock ()
603 heller 1.1 (defun break (&optional (format-string "Break") &rest args)
604     (if (not sys::*use-clcs*)
605     (progn
606 mbaringer 1.63 (terpri *error-output*)
607     (apply #'format *error-output*
608     (concatenate 'string "*** - " format-string)
609     args)
610     (funcall ext:*break-driver* t))
611 heller 1.1 (let ((condition
612 mbaringer 1.63 (make-condition 'simple-condition
613     :format-control format-string
614     :format-arguments args))
615     ;;(*debugger-hook* nil)
616     ;; Issue 91
617     )
618     (ext:with-restarts
619     ((continue
620     :report (lambda (stream)
621     (format stream (sys::text "Return from ~S loop")
622     'break))
623     ()))
624     (with-condition-restarts condition (list (find-restart 'continue))
625     (invoke-debugger condition)))))
626 heller 1.1 nil))
627 heller 1.40
628 mbaringer 1.63 ;;;; Inspecting
629 heller 1.23
630 heller 1.66 (defmethod emacs-inspect ((o t))
631 heller 1.23 (let* ((*print-array* nil) (*print-pretty* t)
632 mbaringer 1.63 (*print-circle* t) (*print-escape* t)
633     (*print-lines* custom:*inspect-print-lines*)
634     (*print-level* custom:*inspect-print-level*)
635     (*print-length* custom:*inspect-print-length*)
636     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
637     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
638     (*package* tmp-pack)
639     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
640 heller 1.23 (let ((inspection (sys::inspect-backend o)))
641 mbaringer 1.63 (values (format nil "~S~% ~A~{~%~A~}" o
642     (sys::insp-title inspection)
643     (sys::insp-blurb inspection))
644 mbaringer 1.35 (loop with count = (sys::insp-num-slots inspection)
645 mbaringer 1.63 for i below count
646     append (multiple-value-bind (value name)
647     (funcall (sys::insp-nth-slot inspection)
648     i)
649     `((:value ,name) " = " (:value ,value)
650     (:newline))))))))
651 heller 1.1
652 mbaringer 1.29 (defimplementation quit-lisp ()
653 heller 1.39 #+lisp=cl (ext:quit)
654     #-lisp=cl (lisp:quit))
655 mbaringer 1.29
656 mkoeppe 1.61 ;;;; Weak hashtables
657    
658     (defimplementation make-weak-key-hash-table (&rest args)
659     (apply #'make-hash-table :weak :key args))
660    
661     (defimplementation make-weak-value-hash-table (&rest args)
662     (apply #'make-hash-table :weak :value args))
663    
664 heller 1.1 ;;; Local Variables:
665     ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
666 heller 1.25 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
667 heller 1.1 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5