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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (show annotations)
Wed Jun 1 12:22:28 2005 UTC (8 years, 10 months ago) by heller
Branch: MAIN
Changes since 1.46: +16 -9 lines
Distinguish macro and special operators from functions.
1 ;;;; SWANK support for CLISP.
2
3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
4
5 ;;;; swank-clisp.lisp is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU General Public License as
7 ;;;; published by the Free Software Foundation; either version 2, or
8 ;;;; (at your option) any later version.
9
10 ;;; This is work in progress, but it's already usable. Many things
11 ;;; are adapted from other swank-*.lisp, in particular from
12 ;;; swank-allegro (I don't use allegro at all, but it's the shortest
13 ;;; one and I found Helmut Eller's code there enlightening).
14
15 ;;; This code is developed using the current CVS version of CLISP and
16 ;;; CLISP 2.32 on Linux. Older versions may not work (2.29 and below
17 ;;; are confirmed non-working; please upgrade). You need an image
18 ;;; containing the "SOCKET", "REGEXP", and "LINUX" packages. The
19 ;;; portable xref from the CMU AI repository and metering.lisp from
20 ;;; CLOCC [1] are also required (alternatively, you have to manually
21 ;;; comment out some code below).
22 ;;;
23 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
24
25 (in-package :swank-backend)
26
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 ;;(use-package "SOCKET")
29 (use-package "GRAY"))
30
31 (eval-when (:compile-toplevel :execute)
32 (when (find-package "LINUX")
33 (pushnew :linux *features*)))
34
35 ;;;; if this listp has the complete CLOS then we use it, othewise we
36 ;;;; build up a "fake" swank-mop and then overide the methods in the
37 ;;;; inspector.
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 (defvar *have-mop*
41 (and (find-package :clos)
42 (eql :external
43 (nth-value 1 (find-symbol (string ':standard-slot-definition)
44 :clos))))
45 "True in those CLISP imagse which have a complete MOP implementation."))
46
47 #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
48 (progn
49 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
50
51 (defun swank-mop:slot-definition-documentation (slot)
52 (clos::slot-definition-documentation slot)))
53
54 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
55 (defclass swank-mop:standard-slot-definition ()
56 ()
57 (:documentation
58 "Dummy class created so that swank.lisp will compile and load."))
59
60 #+linux
61 (defmacro with-blocked-signals ((&rest signals) &body body)
62 (ext:with-gensyms ("SIGPROCMASK" ret mask)
63 `(multiple-value-bind (,ret ,mask)
64 (linux:sigprocmask-set-n-save
65 ,linux:SIG_BLOCK
66 ,(do ((sigset (linux:sigset-empty)
67 (linux:sigset-add sigset (the fixnum (pop signals)))))
68 ((null signals) sigset)))
69 (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
70 (unwind-protect
71 (progn ,@body)
72 (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
73
74 ;; XXX currently only works in CVS version. 2.32 breaks.
75 ;; #+linux
76 ;; (defimplementation call-without-interrupts (fn)
77 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
78 ;;
79 ;; #-linux
80 (defimplementation call-without-interrupts (fn)
81 (funcall fn))
82
83 #+unix
84 (defmethod getpid ()
85 (funcall (or (find-symbol "PROGRAM-ID" :system)
86 (find-symbol "PROCESS-ID" :system)
87 (error "getpid not implemented"))))
88
89 #+win32
90 (defmethod getpid ()
91 (cond ((find-package :win32)
92 (funcall (find-symbol "GetCurrentProcessId" :win32)))
93 (t
94 (system::getenv "PID"))))
95
96 ;; the above is likely broken; we need windows NT users!
97
98 (defimplementation lisp-implementation-type-name ()
99 "clisp")
100
101 (defimplementation set-default-directory (directory)
102 (setf (ext:default-directory) directory)
103 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
104
105
106 ;;; TCP Server
107
108 (defimplementation create-socket (host port)
109 (declare (ignore host))
110 (socket:socket-server port))
111
112 (defimplementation local-port (socket)
113 (socket:socket-server-port socket))
114
115 (defimplementation close-socket (socket)
116 (socket:socket-server-close socket))
117
118 (defun find-encoding (external-format)
119 (ecase external-format
120 (:iso-latin-1-unix (ext:make-encoding :charset 'charset:iso-8859-1
121 :line-terminator :unix))
122 (:utf-8-unix (ext:make-encoding :charset 'charset:utf-8
123 :line-terminator :unix))))
124
125 (defimplementation accept-connection (socket
126 &key (external-format :iso-latin-1-unix))
127 (socket:socket-accept socket
128 :buffered nil ;; XXX should be t
129 :element-type 'character
130 :external-format (find-encoding external-format)))
131
132 ;;; Swank functions
133
134 (defimplementation arglist (fname)
135 (block nil
136 (or (ignore-errors (return (ext:arglist fname)))
137 :not-available)))
138
139 (defimplementation macroexpand-all (form)
140 (ext:expand-form form))
141
142 (defimplementation describe-symbol-for-emacs (symbol)
143 "Return a plist describing SYMBOL.
144 Return NIL if the symbol is unbound."
145 (let ((result ()))
146 (flet ((doc (kind)
147 (or (documentation symbol kind) :not-documented))
148 (maybe-push (property value)
149 (when value
150 (setf result (list* property value result)))))
151 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
152 (when (fboundp symbol)
153 (maybe-push
154 ;; Report WHEN etc. as macros, even though they may be
155 ;; implemented as special operators.
156 (if (macro-function symbol) :macro
157 (typecase (fdefinition symbol)
158 (generic-function :generic-function)
159 (function :function)
160 ;; (type-of 'progn) -> ext:special-operator
161 (t :special-operator)))
162 (doc 'function)))
163 (maybe-push :class (when (find-class symbol nil)
164 (doc 'type))) ;this should be fixed
165 result)))
166
167 (defimplementation describe-definition (symbol namespace)
168 (ecase namespace
169 (:variable (describe symbol))
170 (:macro (describe (macro-function symbol)))
171 (:function (describe (symbol-function symbol)))
172 (:class (describe (find-class symbol)))))
173
174 (defun fspec-pathname (symbol)
175 (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
176 (if (and path
177 (member (pathname-type path)
178 custom:*compiled-file-types* :test #'string=))
179 (loop for suffix in custom:*source-file-types*
180 thereis (make-pathname :defaults path :type suffix))
181 path)))
182
183 (defun fspec-location (fspec)
184 (let ((file (fspec-pathname fspec)))
185 (cond (file
186 (multiple-value-bind (truename c) (ignore-errors (truename file))
187 (cond (truename
188 (make-location (list :file (namestring truename))
189 (list :function-name (string fspec))))
190 (t (list :error (princ-to-string c))))))
191 (t (list :error (format nil "No source information available for: ~S"
192 fspec))))))
193
194 (defimplementation find-definitions (name)
195 (list (list name (fspec-location name))))
196
197 (defvar *sldb-topframe*)
198 (defvar *sldb-botframe*)
199 (defvar *sldb-source*)
200 (defvar *sldb-debugmode* 4)
201
202 (defun frame-down (frame)
203 (sys::frame-down-1 frame sys::*debug-mode*))
204
205 (defun frame-up (frame)
206 (sys::frame-up-1 frame sys::*debug-mode*))
207
208 (defimplementation call-with-debugging-environment (debugger-loop-fn)
209 (let* ((sys::*break-count* (1+ sys::*break-count*))
210 (sys::*driver* debugger-loop-fn)
211 (sys::*fasoutput-stream* nil)
212 (sys::*frame-limit1* (sys::frame-limit1 0))
213 (sys::*frame-limit2* (sys::frame-limit2))
214 (sys::*debug-mode* *sldb-debugmode*)
215 (*sldb-topframe* sys::*frame-limit1*))
216 (funcall debugger-loop-fn)))
217
218 (defun nth-frame (index)
219 (loop for frame = *sldb-topframe* then (frame-up frame)
220 repeat index
221 finally (return frame)))
222
223 (defimplementation compute-backtrace (start end)
224 (let ((end (or end most-positive-fixnum)))
225 (loop for last = nil then frame
226 for frame = (nth-frame start) then (frame-up frame)
227 for i from start below end
228 until (or (eq frame last) (system::driver-frame-p frame))
229 collect frame)))
230
231 (defimplementation print-frame (frame stream)
232 (write-string (string-left-trim '(#\Newline)
233 (with-output-to-string (stream)
234 (sys::describe-frame stream frame)))
235 stream))
236
237 (defimplementation eval-in-frame (form frame-number)
238 (sys::eval-at (nth-frame frame-number) form))
239
240 (defimplementation frame-locals (frame-number)
241 (let* ((frame (nth-frame frame-number))
242 (frame-env (sys::eval-at frame '(sys::the-environment))))
243 (append
244 (frame-do-venv frame (svref frame-env 0))
245 (frame-do-fenv frame (svref frame-env 1))
246 (frame-do-benv frame (svref frame-env 2))
247 (frame-do-genv frame (svref frame-env 3))
248 (frame-do-denv frame (svref frame-env 4)))))
249
250 (defimplementation frame-var-value (frame var)
251 (getf (nth var (frame-locals frame)) :value))
252
253 ;; Interpreter-Variablen-Environment has the shape
254 ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
255
256 (defun frame-do-venv (frame venv)
257 (loop for i from 1 below (length venv) by 2
258 as symbol = (svref venv (1- i))
259 and value = (svref venv i)
260 collect (list :name symbol :id 0
261 :value (if (eq sys::specdecl value)
262 ;; special variable
263 (sys::eval-at frame symbol)
264 ;; lexical variable or symbol macro
265 value))))
266
267 (defun frame-do-fenv (frame fenv)
268 (declare (ignore frame fenv))
269 nil)
270
271 (defun frame-do-benv (frame benv)
272 (declare (ignore frame benv))
273 nil)
274
275 (defun frame-do-genv (frame genv)
276 (declare (ignore frame genv))
277 nil)
278
279 (defun frame-do-denv (frame denv)
280 (declare (ignore frame denv))
281 nil)
282
283 (defimplementation frame-catch-tags (index)
284 (declare (ignore index))
285 nil)
286
287 (defimplementation return-from-frame (index form)
288 (sys::return-from-eval-frame (nth-frame index) form))
289
290 (defimplementation restart-frame (index)
291 (sys::redo-eval-frame (nth-frame index)))
292
293 (defimplementation frame-source-location-for-emacs (index)
294 (let ((f (nth-frame index)))
295 (list :error (format nil "Cannot find source for frame: ~A ~A ~A"
296 f
297 (sys::eval-frame-p f)
298 (sys::the-frame)))))
299
300 ;;; Profiling
301
302 (defimplementation profile (fname)
303 (eval `(mon:monitor ,fname))) ;monitor is a macro
304
305 (defimplementation profiled-functions ()
306 mon:*monitored-functions*)
307
308 (defimplementation unprofile (fname)
309 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
310
311 (defimplementation unprofile-all ()
312 (mon:unmonitor))
313
314 (defimplementation profile-report ()
315 (mon:report-monitoring))
316
317 (defimplementation profile-reset ()
318 (mon:reset-all-monitoring))
319
320 (defimplementation profile-package (package callers-p methods)
321 (declare (ignore callers-p methods))
322 (mon:monitor-all package))
323
324 ;;; Handle compiler conditions (find out location of error etc.)
325
326 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
327 "Pass ARGS to COMPILE-FILE, send the compiler notes to
328 *STANDARD-INPUT* and frob them in BODY."
329 `(let ((*error-output* (make-string-output-stream))
330 (*compile-verbose* t))
331 (multiple-value-prog1
332 (compile-file ,@args)
333 (handler-case
334 (with-input-from-string
335 (*standard-input* (get-output-stream-string *error-output*))
336 ,@body)
337 (sys::simple-end-of-file () nil)))))
338
339 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
340 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
341 (defvar *orig-c-error* (symbol-function 'system::c-error))
342 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
343
344 (defmacro dynamic-flet (names-functions &body body)
345 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
346 Execute BODY with NAME's function slot set to FUNCTION."
347 `(ext:letf* ,(loop for (name function) in names-functions
348 collect `((symbol-function ',name) ,function))
349 ,@body))
350
351 (defvar *buffer-name* nil)
352 (defvar *buffer-offset*)
353
354 (defun compiler-note-location ()
355 "Return the current compiler location."
356 (let ((lineno1 sys::*compile-file-lineno1*)
357 (lineno2 sys::*compile-file-lineno2*)
358 (file sys::*compile-file-truename*))
359 (cond ((and file lineno1 lineno2)
360 (make-location (list ':file (namestring file))
361 (list ':line lineno1)))
362 (*buffer-name*
363 (make-location (list ':buffer *buffer-name*)
364 (list ':position *buffer-offset*)))
365 (t
366 (list :error "No error location available")))))
367
368 (defun signal-compiler-warning (cstring args severity orig-fn)
369 (signal (make-condition 'compiler-condition
370 :severity severity
371 :message (apply #'format nil cstring args)
372 :location (compiler-note-location)))
373 (apply orig-fn cstring args))
374
375 (defun c-warn (cstring &rest args)
376 (signal-compiler-warning cstring args :warning *orig-c-warn*))
377
378 (defun c-style-warn (cstring &rest args)
379 (dynamic-flet ((sys::c-warn *orig-c-warn*))
380 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
381
382 (defun c-error (cstring &rest args)
383 (signal-compiler-warning cstring args :error *orig-c-error*))
384
385 (defimplementation call-with-compilation-hooks (function)
386 (handler-bind ((warning #'handle-notification-condition))
387 (dynamic-flet ((system::c-warn #'c-warn)
388 (system::c-style-warn #'c-style-warn)
389 (system::c-error #'c-error))
390 (funcall function))))
391
392 (defun handle-notification-condition (condition)
393 "Handle a condition caused by a compiler warning."
394 (signal (make-condition 'compiler-condition
395 :original-condition condition
396 :severity :warning
397 :message (princ-to-string condition)
398 :location (compiler-note-location))))
399
400 (defimplementation swank-compile-file (filename load-p)
401 (with-compilation-hooks ()
402 (with-compilation-unit ()
403 (let ((fasl-file (compile-file filename)))
404 (when (and load-p fasl-file)
405 (load fasl-file))
406 nil))))
407
408 (defimplementation swank-compile-string (string &key buffer position directory)
409 (declare (ignore directory))
410 (with-compilation-hooks ()
411 (let ((*buffer-name* buffer)
412 (*buffer-offset* position))
413 (funcall (compile nil (read-from-string
414 (format nil "(~S () ~A)" 'lambda string)))))))
415
416 ;;; Portable XREF from the CMU AI repository.
417
418 (setq pxref::*handle-package-forms* '(cl:in-package))
419
420 (defmacro defxref (name function)
421 `(defimplementation ,name (name)
422 (xref-results (,function name))))
423
424 (defxref who-calls pxref:list-callers)
425 (defxref who-references pxref:list-readers)
426 (defxref who-binds pxref:list-setters)
427 (defxref who-sets pxref:list-setters)
428 (defxref list-callers pxref:list-callers)
429 (defxref list-callees pxref:list-callees)
430
431 (defun xref-results (symbols)
432 (let ((xrefs '()))
433 (dolist (symbol symbols)
434 (push (list symbol (fspec-location symbol)) xrefs))
435 xrefs))
436
437 (when (find-package :swank-loader)
438 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
439 (lambda ()
440 (let ((home (user-homedir-pathname)))
441 (and (ext:probe-directory home)
442 (probe-file (format nil "~A/.swank.lisp"
443 (namestring (truename home)))))))))
444
445 ;; Don't set *debugger-hook* to nil on break.
446 (ext:without-package-lock ()
447 (defun break (&optional (format-string "Break") &rest args)
448 (if (not sys::*use-clcs*)
449 (progn
450 (terpri *error-output*)
451 (apply #'format *error-output*
452 (concatenate 'string "*** - " format-string)
453 args)
454 (funcall ext:*break-driver* t))
455 (let ((condition
456 (make-condition 'simple-condition
457 :format-control format-string
458 :format-arguments args))
459 ;;(*debugger-hook* nil)
460 ;; Issue 91
461 )
462 (ext:with-restarts
463 ((continue
464 :report (lambda (stream)
465 (format stream (sys::text "Return from ~S loop")
466 'break))
467 ()))
468 (with-condition-restarts condition (list (find-restart 'continue))
469 (invoke-debugger condition)))))
470 nil))
471
472 ;;; Inspecting
473
474 (defclass clisp-inspector (inspector)
475 ())
476
477 (defimplementation make-default-inspector ()
478 (make-instance 'clisp-inspector))
479
480 (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
481 (declare (ignore inspector))
482 (let* ((*print-array* nil) (*print-pretty* t)
483 (*print-circle* t) (*print-escape* t)
484 (*print-lines* custom:*inspect-print-lines*)
485 (*print-level* custom:*inspect-print-level*)
486 (*print-length* custom:*inspect-print-length*)
487 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
488 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
489 (*package* tmp-pack)
490 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
491 (let ((inspection (sys::inspect-backend o)))
492 (values (format nil "~S~% ~A~{~%~A~}" o
493 (sys::insp-title inspection)
494 (sys::insp-blurb inspection))
495 (loop with count = (sys::insp-num-slots inspection)
496 for i upto count
497 for (value name) = (multiple-value-list
498 (funcall (sys::insp-nth-slot
499 inspection) i))
500 collect `((:value ,name) " = " (:value ,value)
501 (:newline)))))))
502
503 (defimplementation quit-lisp ()
504 #+lisp=cl (ext:quit)
505 #-lisp=cl (lisp:quit))
506
507 ;;; Local Variables:
508 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
509 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
510 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5