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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78 - (show annotations)
Wed Sep 17 06:19:48 2008 UTC (5 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.77: +1 -1 lines
Adjust positions in files with CRLF-style end-on-line markers.

* slime.el (slime-eol-conversion-fixup): New function.
(slime-goto-location-position): Use it.  Also add a new position
type :offset, so that we don't adjust offsets in strings that were
sent over the wire (which uses LF eol-convention).

* swank-abcl.lisp
* swank-allegro.lisp
* swank-clisp.lisp
* swank-cmucl.lisp
* swank-corman.lisp
* swank-ecl.lisp
* swank-lispworks.lisp
* swank-openmcl.lisp
* swank-sbcl.lisp
* swank-scl.lisp: Create :offset style positions where needed.

* swank-lispworks.lisp (skip-comments): New function.
(dspec-stream-position): Use it.
1 ;;;; -*- indent-tabs-mode: nil -*-
2
3 ;;;; SWANK support for CLISP.
4
5 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
6
7 ;;;; This program is free software; you can redistribute it and/or
8 ;;;; modify it under the terms of the GNU General Public License as
9 ;;;; 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
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 ;;; 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 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
36
37 (in-package :swank-backend)
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 ;;(use-package "SOCKET")
41 (use-package "GRAY"))
42
43 ;;;; 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 ;;;; inspector.
46
47 (eval-when (:compile-toplevel :load-toplevel :execute)
48 (defvar *have-mop*
49 (and (find-package :clos)
50 (eql :external
51 (nth-value 1 (find-symbol (string ':standard-slot-definition)
52 :clos))))
53 "True in those CLISP images which have a complete MOP implementation."))
54
55 #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
56 (progn
57 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
58
59 (defun swank-mop:slot-definition-documentation (slot)
60 (clos::slot-definition-documentation slot)))
61
62 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
63 (defclass swank-mop:standard-slot-definition ()
64 ()
65 (:documentation
66 "Dummy class created so that swank.lisp will compile and load."))
67
68 ;; #+#.(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 ;; (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
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 (defimplementation call-without-interrupts (fn)
88 (funcall fn))
89
90 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
91 ;; 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 (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
102 (defimplementation call-with-user-break-handler (handler function)
103 (handler-bind ((system::simple-interrupt-condition
104 (lambda (c)
105 (declare (ignore c))
106 (funcall handler)
107 (when (find-restart 'socket-status)
108 (invoke-restart (find-restart 'socket-status)))
109 (continue))))
110 (funcall function)))
111
112 (defimplementation lisp-implementation-type-name ()
113 "clisp")
114
115 (defimplementation set-default-directory (directory)
116 (setf (ext:default-directory) directory)
117 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
118
119 ;;;; TCP Server
120
121 (defimplementation create-socket (host port)
122 (declare (ignore host))
123 (socket:socket-server port))
124
125 (defimplementation local-port (socket)
126 (socket:socket-server-port socket))
127
128 (defimplementation close-socket (socket)
129 (socket:socket-server-close socket))
130
131 (defimplementation accept-connection (socket
132 &key external-format buffering timeout)
133 (declare (ignore buffering timeout))
134 (socket:socket-accept socket
135 :buffered nil ;; XXX should be t
136 :element-type 'character
137 :external-format external-format))
138
139 (defimplementation wait-for-input (streams &optional timeout)
140 (assert (member timeout '(nil t)))
141 (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
142 (loop
143 (cond ((check-slime-interrupts) (return :interrupt))
144 (timeout
145 (socket:socket-status streams 0 0)
146 (return (loop for (s _ . x) in streams
147 if x collect s)))
148 (t
149 (with-simple-restart (socket-status "Return from socket-status.")
150 (socket:socket-status streams 0 500000))
151 (let ((ready (loop for (s _ . x) in streams
152 if x collect s)))
153 (when ready (return ready))))))))
154
155 ;;;; Coding systems
156
157 (defvar *external-format-to-coding-system*
158 '(((:charset "iso-8859-1" :line-terminator :unix)
159 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
160 ((:charset "iso-8859-1":latin-1)
161 "latin-1" "iso-latin-1" "iso-8859-1")
162 ((:charset "utf-8") "utf-8")
163 ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
164 ((:charset "euc-jp") "euc-jp")
165 ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
166 ((:charset "us-ascii") "us-ascii")
167 ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
168
169 (defimplementation find-external-format (coding-system)
170 (let ((args (car (rassoc-if (lambda (x)
171 (member coding-system x :test #'equal))
172 *external-format-to-coding-system*))))
173 (and args (apply #'ext:make-encoding args))))
174
175
176 ;;;; Swank functions
177
178 (defimplementation arglist (fname)
179 (block nil
180 (or (ignore-errors
181 (let ((exp (function-lambda-expression fname)))
182 (and exp (return (second exp)))))
183 (ignore-errors
184 (return (ext:arglist fname)))
185 :not-available)))
186
187 (defimplementation macroexpand-all (form)
188 (ext:expand-form form))
189
190 (defimplementation describe-symbol-for-emacs (symbol)
191 "Return a plist describing SYMBOL.
192 Return NIL if the symbol is unbound."
193 (let ((result ()))
194 (flet ((doc (kind)
195 (or (documentation symbol kind) :not-documented))
196 (maybe-push (property value)
197 (when value
198 (setf result (list* property value result)))))
199 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
200 (when (fboundp symbol)
201 (maybe-push
202 ;; Report WHEN etc. as macros, even though they may be
203 ;; implemented as special operators.
204 (if (macro-function symbol) :macro
205 (typecase (fdefinition symbol)
206 (generic-function :generic-function)
207 (function :function)
208 ;; (type-of 'progn) -> ext:special-operator
209 (t :special-operator)))
210 (doc 'function)))
211 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
212 (get symbol 'system::setf-expander)); defsetf
213 (maybe-push :setf (doc 'setf)))
214 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
215 (get symbol 'system::defstruct-description)
216 (get symbol 'system::deftype-expander))
217 (maybe-push :type (doc 'type))) ; even for 'structure
218 (when (find-class symbol nil)
219 (maybe-push :class (doc 'type)))
220 ;; Let this code work compiled in images without FFI
221 (let ((types (load-time-value
222 (and (find-package "FFI")
223 (symbol-value
224 (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
225 ;; Use ffi::*c-type-table* so as not to suffer the overhead of
226 ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
227 ;; which are not FFI type names.
228 (when (and types (nth-value 1 (gethash symbol types)))
229 ;; Maybe use (case (head (ffi:deparse-c-type)))
230 ;; to distinguish struct and union types?
231 (maybe-push :alien-type :not-documented)))
232 result)))
233
234 (defimplementation describe-definition (symbol namespace)
235 (ecase namespace
236 (:variable (describe symbol))
237 (:macro (describe (macro-function symbol)))
238 (:function (describe (symbol-function symbol)))
239 (:class (describe (find-class symbol)))))
240
241 (defun fspec-pathname (spec)
242 (let ((path spec)
243 type
244 lines)
245 (when (consp path)
246 (psetq type (car path)
247 path (cadr path)
248 lines (cddr path)))
249 (when (and path
250 (member (pathname-type path)
251 custom:*compiled-file-types* :test #'equal))
252 (setq path
253 (loop for suffix in custom:*source-file-types*
254 thereis (probe-file (make-pathname :defaults path
255 :type suffix)))))
256 (values path type lines)))
257
258 (defun fspec-location (name fspec)
259 (multiple-value-bind (file type lines)
260 (fspec-pathname fspec)
261 (list (if type (list name type) name)
262 (cond (file
263 (multiple-value-bind (truename c) (ignore-errors (truename file))
264 (cond (truename
265 (make-location (list :file (namestring truename))
266 (if (consp lines)
267 (list* :line lines)
268 (list :function-name (string fspec)))
269 (list :snippet (format nil "~A" type))))
270 (t (list :error (princ-to-string c))))))
271 (t (list :error (format nil "No source information available for: ~S"
272 fspec)))))))
273
274 (defimplementation find-definitions (name)
275 (mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file)))
276
277 (defun trim-whitespace (string)
278 (string-trim #(#\newline #\space #\tab) string))
279
280 (defvar *sldb-backtrace*)
281
282 (eval-when (:compile-toplevel :load-toplevel :execute)
283 (when (string< "2.44" (lisp-implementation-version))
284 (pushnew :clisp-2.44+ *features*)))
285
286 (defun sldb-backtrace ()
287 "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
288 (do ((frames '())
289 (last nil frame)
290 (frame (sys::the-frame)
291 #+clisp-2.44+ (sys::frame-up 1 frame 1)
292 #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
293 ((eq frame last) (nreverse frames))
294 (unless (boring-frame-p frame)
295 (push frame frames))))
296
297 (defimplementation call-with-debugging-environment (debugger-loop-fn)
298 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
299 ;;(sys::*driver* debugger-loop-fn)
300 ;;(sys::*fasoutput-stream* nil)
301 (*sldb-backtrace*
302 (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
303 (funcall debugger-loop-fn)))
304
305 (defun nth-frame (index)
306 (nth index *sldb-backtrace*))
307
308 (defun boring-frame-p (frame)
309 (member (frame-type frame) '(stack-value bind-var bind-env)))
310
311 (defun frame-to-string (frame)
312 (with-output-to-string (s)
313 (sys::describe-frame s frame)))
314
315 ;; FIXME: they changed the layout in 2.44 so the frame-to-string &
316 ;; string-matching silliness no longer works.
317 (defun frame-type (frame)
318 ;; FIXME: should bind *print-length* etc. to small values.
319 (frame-string-type (frame-to-string frame)))
320
321 (defvar *frame-prefixes*
322 '(("frame binding variables" bind-var)
323 ("<1> #<compiled-function" compiled-fun)
324 ("<1> #<system-function" sys-fun)
325 ("<1> #<special-operator" special-op)
326 ("EVAL frame" eval)
327 ("APPLY frame" apply)
328 ("compiled tagbody frame" compiled-tagbody)
329 ("compiled block frame" compiled-block)
330 ("block frame" block)
331 ("nested block frame" block)
332 ("tagbody frame" tagbody)
333 ("nested tagbody frame" tagbody)
334 ("catch frame" catch)
335 ("handler frame" handler)
336 ("unwind-protect frame" unwind-protect)
337 ("driver frame" driver)
338 ("frame binding environments" bind-env)
339 ("CALLBACK frame" callback)
340 ("- " stack-value)
341 ("<1> " fun)
342 ("<2> " 2nd-frame)))
343
344 (defun frame-string-type (string)
345 (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
346 *frame-prefixes*)))
347
348 (defimplementation compute-backtrace (start end)
349 (let* ((bt *sldb-backtrace*)
350 (len (length bt)))
351 (loop for f in (subseq bt start (min (or end len) len))
352 collect (make-swank-frame :%frame f :restartable :unknown))))
353
354 ;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we
355 ;;; can omit that restart so that users don't select it by mistake.
356 (defimplementation compute-sane-restarts (condition)
357 ;; The outermost restart is specified to be the last element of the
358 ;; list, hopefully that's our unwanted ABORT restart.
359 (butlast (compute-restarts condition)))
360
361 (defimplementation print-swank-frame (swank-frame stream)
362 (let* ((frame (swank-frame.%frame swank-frame))
363 (str (frame-to-string frame)))
364 (write-string (extract-frame-line str)
365 stream)))
366
367 (defun extract-frame-line (frame-string)
368 (let ((s frame-string))
369 (trim-whitespace
370 (case (frame-string-type s)
371 ((eval special-op)
372 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
373 (apply
374 (string-match "APPLY frame for call \\(.*\\)" s 1))
375 ((compiled-fun sys-fun fun)
376 (extract-function-name s))
377 (t s)))))
378
379 (defun extract-function-name (string)
380 (let ((1st (car (split-frame-string string))))
381 (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
382 1st
383 1)
384 (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
385 1st)))
386
387 (defun split-frame-string (string)
388 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
389 (mapcar #'car *frame-prefixes*))))
390 (loop for pos = 0 then (1+ (regexp:match-start match))
391 for match = (regexp:match rx string :start pos)
392 if match collect (subseq string pos (regexp:match-start match))
393 else collect (subseq string pos)
394 while match)))
395
396 (defun string-match (pattern string n)
397 (let* ((match (nth-value n (regexp:match pattern string))))
398 (if match (regexp:match-string string match))))
399
400 (defimplementation format-sldb-condition (condition)
401 (trim-whitespace (princ-to-string condition)))
402
403 (defimplementation eval-in-frame (form frame-number)
404 (sys::eval-at (nth-frame frame-number) form))
405
406 (defimplementation frame-locals (frame-number)
407 (let ((frame (nth-frame frame-number)))
408 (loop for i below (%frame-count-vars frame)
409 collect (list :name (%frame-var-name frame i)
410 :value (%frame-var-value frame i)
411 :id 0))))
412
413 (defimplementation frame-var-value (frame var)
414 (%frame-var-value (nth-frame frame) var))
415
416 ;;; Interpreter-Variablen-Environment has the shape
417 ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
418
419 (defun %frame-count-vars (frame)
420 (cond ((sys::eval-frame-p frame)
421 (do ((venv (frame-venv frame) (next-venv venv))
422 (count 0 (+ count (/ (1- (length venv)) 2))))
423 ((not venv) count)))
424 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
425 (length (%parse-stack-values frame)))
426 (t 0)))
427
428 (defun %frame-var-name (frame i)
429 (cond ((sys::eval-frame-p frame)
430 (nth-value 0 (venv-ref (frame-venv frame) i)))
431 (t (format nil "~D" i))))
432
433 (defun %frame-var-value (frame i)
434 (cond ((sys::eval-frame-p frame)
435 (let ((name (venv-ref (frame-venv frame) i)))
436 (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
437 (if c
438 (format-sldb-condition c)
439 v))))
440 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
441 (let ((str (nth i (%parse-stack-values frame))))
442 (trim-whitespace (subseq str 2))))
443 (t (break "Not implemented"))))
444
445 (defun frame-venv (frame)
446 (let ((env (sys::eval-at frame '(sys::the-environment))))
447 (svref env 0)))
448
449 (defun next-venv (venv) (svref venv (1- (length venv))))
450
451 (defun venv-ref (env i)
452 "Reference the Ith binding in ENV.
453 Return two values: NAME and VALUE"
454 (let ((idx (* i 2)))
455 (if (< idx (1- (length env)))
456 (values (svref env idx) (svref env (1+ idx)))
457 (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
458
459 (defun %parse-stack-values (frame)
460 (labels ((next (fp)
461 #+clisp-2.44+ (sys::frame-down 1 fp 1)
462 #-clisp-2.44+ (sys::frame-down-1 fp 1))
463 (parse (fp accu)
464 (let ((str (frame-to-string fp)))
465 (cond ((is-prefix-p "- " str)
466 (parse (next fp) (cons str accu)))
467 ((is-prefix-p "<1> " str)
468 ;;(when (eq (frame-type frame) 'compiled-fun)
469 ;; (pop accu))
470 (dolist (str (cdr (split-frame-string str)))
471 (when (is-prefix-p "- " str)
472 (push str accu)))
473 (nreverse accu))
474 (t (parse (next fp) accu))))))
475 (parse (next frame) '())))
476
477 (setq *features* (remove :clisp-2.44+ *features*))
478
479 (defun is-prefix-p (pattern string)
480 (not (mismatch pattern string :end2 (min (length pattern)
481 (length string)))))
482
483 (defimplementation frame-catch-tags (index)
484 (declare (ignore index))
485 nil)
486
487 (defimplementation return-from-frame (index form)
488 (sys::return-from-eval-frame (nth-frame index) form))
489
490 (defimplementation restart-frame (index)
491 (sys::redo-eval-frame (nth-frame index)))
492
493 (defimplementation frame-source-location-for-emacs (index)
494 `(:error
495 ,(format nil "frame-source-location not implemented. (frame: ~A)"
496 (nth-frame index))))
497
498 ;;;; Profiling
499
500 (defimplementation profile (fname)
501 (eval `(mon:monitor ,fname))) ;monitor is a macro
502
503 (defimplementation profiled-functions ()
504 mon:*monitored-functions*)
505
506 (defimplementation unprofile (fname)
507 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
508
509 (defimplementation unprofile-all ()
510 (mon:unmonitor))
511
512 (defimplementation profile-report ()
513 (mon:report-monitoring))
514
515 (defimplementation profile-reset ()
516 (mon:reset-all-monitoring))
517
518 (defimplementation profile-package (package callers-p methods)
519 (declare (ignore callers-p methods))
520 (mon:monitor-all package))
521
522 ;;;; Handle compiler conditions (find out location of error etc.)
523
524 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
525 "Pass ARGS to COMPILE-FILE, send the compiler notes to
526 *STANDARD-INPUT* and frob them in BODY."
527 `(let ((*error-output* (make-string-output-stream))
528 (*compile-verbose* t))
529 (multiple-value-prog1
530 (compile-file ,@args)
531 (handler-case
532 (with-input-from-string
533 (*standard-input* (get-output-stream-string *error-output*))
534 ,@body)
535 (sys::simple-end-of-file () nil)))))
536
537 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
538 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
539 (defvar *orig-c-error* (symbol-function 'system::c-error))
540 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
541
542 (defmacro dynamic-flet (names-functions &body body)
543 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
544 Execute BODY with NAME's function slot set to FUNCTION."
545 `(ext:letf* ,(loop for (name function) in names-functions
546 collect `((symbol-function ',name) ,function))
547 ,@body))
548
549 (defvar *buffer-name* nil)
550 (defvar *buffer-offset*)
551
552 (defun compiler-note-location ()
553 "Return the current compiler location."
554 (let ((lineno1 sys::*compile-file-lineno1*)
555 (lineno2 sys::*compile-file-lineno2*)
556 (file sys::*compile-file-truename*))
557 (cond ((and file lineno1 lineno2)
558 (make-location (list ':file (namestring file))
559 (list ':line lineno1)))
560 (*buffer-name*
561 (make-location (list ':buffer *buffer-name*)
562 (list ':offset *buffer-offset* 0)))
563 (t
564 (list :error "No error location available")))))
565
566 (defun signal-compiler-warning (cstring args severity orig-fn)
567 (signal (make-condition 'compiler-condition
568 :severity severity
569 :message (apply #'format nil cstring args)
570 :location (compiler-note-location)))
571 (apply orig-fn cstring args))
572
573 (defun c-warn (cstring &rest args)
574 (signal-compiler-warning cstring args :warning *orig-c-warn*))
575
576 (defun c-style-warn (cstring &rest args)
577 (dynamic-flet ((sys::c-warn *orig-c-warn*))
578 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
579
580 (defun c-error (cstring &rest args)
581 (signal-compiler-warning cstring args :error *orig-c-error*))
582
583 (defimplementation call-with-compilation-hooks (function)
584 (handler-bind ((warning #'handle-notification-condition))
585 (dynamic-flet ((system::c-warn #'c-warn)
586 (system::c-style-warn #'c-style-warn)
587 (system::c-error #'c-error))
588 (funcall function))))
589
590 (defun handle-notification-condition (condition)
591 "Handle a condition caused by a compiler warning."
592 (signal (make-condition 'compiler-condition
593 :original-condition condition
594 :severity :warning
595 :message (princ-to-string condition)
596 :location (compiler-note-location))))
597
598 (defimplementation swank-compile-file (filename load-p external-format)
599 (with-compilation-hooks ()
600 (with-compilation-unit ()
601 (let ((fasl-file (compile-file filename
602 :external-format external-format)))
603 (when (and load-p fasl-file)
604 (load fasl-file))
605 nil))))
606
607 (defimplementation swank-compile-string (string &key buffer position directory
608 debug)
609 (declare (ignore directory debug))
610 (with-compilation-hooks ()
611 (let ((*buffer-name* buffer)
612 (*buffer-offset* position))
613 (funcall (compile nil (read-from-string
614 (format nil "(~S () ~A)" 'lambda string)))))))
615
616 ;;;; Portable XREF from the CMU AI repository.
617
618 (setq pxref::*handle-package-forms* '(cl:in-package))
619
620 (defmacro defxref (name function)
621 `(defimplementation ,name (name)
622 (xref-results (,function name))))
623
624 (defxref who-calls pxref:list-callers)
625 (defxref who-references pxref:list-readers)
626 (defxref who-binds pxref:list-setters)
627 (defxref who-sets pxref:list-setters)
628 (defxref list-callers pxref:list-callers)
629 (defxref list-callees pxref:list-callees)
630
631 (defun xref-results (symbols)
632 (let ((xrefs '()))
633 (dolist (symbol symbols)
634 (push (fspec-location symbol symbol) xrefs))
635 xrefs))
636
637 (when (find-package :swank-loader)
638 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
639 (lambda ()
640 (let ((home (user-homedir-pathname)))
641 (and (ext:probe-directory home)
642 (probe-file (format nil "~A/.swank.lisp"
643 (namestring (truename home)))))))))
644
645 ;;; Don't set *debugger-hook* to nil on break.
646 (ext:without-package-lock ()
647 (defun break (&optional (format-string "Break") &rest args)
648 (if (not sys::*use-clcs*)
649 (progn
650 (terpri *error-output*)
651 (apply #'format *error-output*
652 (concatenate 'string "*** - " format-string)
653 args)
654 (funcall ext:*break-driver* t))
655 (let ((condition
656 (make-condition 'simple-condition
657 :format-control format-string
658 :format-arguments args))
659 ;;(*debugger-hook* nil)
660 ;; Issue 91
661 )
662 (ext:with-restarts
663 ((continue
664 :report (lambda (stream)
665 (format stream (sys::text "Return from ~S loop")
666 'break))
667 ()))
668 (with-condition-restarts condition (list (find-restart 'continue))
669 (invoke-debugger condition)))))
670 nil))
671
672 ;;;; Inspecting
673
674 (defmethod emacs-inspect ((o t))
675 (let* ((*print-array* nil) (*print-pretty* t)
676 (*print-circle* t) (*print-escape* t)
677 (*print-lines* custom:*inspect-print-lines*)
678 (*print-level* custom:*inspect-print-level*)
679 (*print-length* custom:*inspect-print-length*)
680 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
681 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
682 (*package* tmp-pack)
683 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
684 (let ((inspection (sys::inspect-backend o)))
685 (append (list
686 (format nil "~S~% ~A~{~%~A~}~%" o
687 (sys::insp-title inspection)
688 (sys::insp-blurb inspection)))
689 (loop with count = (sys::insp-num-slots inspection)
690 for i below count
691 append (multiple-value-bind (value name)
692 (funcall (sys::insp-nth-slot inspection)
693 i)
694 `((:value ,name) " = " (:value ,value)
695 (:newline))))))))
696
697 (defimplementation quit-lisp ()
698 #+lisp=cl (ext:quit)
699 #-lisp=cl (lisp:quit))
700
701 (defimplementation thread-id (thread)
702 (declare (ignore thread))
703 0)
704
705 ;;;; Weak hashtables
706
707 (defimplementation make-weak-key-hash-table (&rest args)
708 (apply #'make-hash-table :weak :key args))
709
710 (defimplementation make-weak-value-hash-table (&rest args)
711 (apply #'make-hash-table :weak :value args))
712
713 (defimplementation save-image (filename &optional restart-function)
714 (let ((args `(,filename
715 ,@(if restart-function
716 `((:init-function ,restart-function))))))
717 (apply #'ext:saveinitmem args)))
718
719 ;;; Local Variables:
720 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
721 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
722 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5