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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24.2.2 - (hide annotations)
Tue Mar 9 12:11:05 2004 UTC (10 years, 1 month ago) by heller
Branch: package-split
Changes since 1.24.2.1: +5 -5 lines
(find-fspec-location): Handle "No such file" errors.
1 heller 1.1 ;;;; SWANK support for CLISP.
2    
3 vsedach 1.3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
4 heller 1.1
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 vsedach 1.3 ;;; 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 wjenkner 1.16 ;;; containing the "SOCKET", "REGEXP", and "LINUX" packages. The
19     ;;; portable xref from the CMU AI repository and metering.lisp from
20 heller 1.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 heller 1.1
25 heller 1.24.2.1 (in-package :swank-backend)
26 heller 1.1
27     (eval-when (:compile-toplevel :load-toplevel :execute)
28     (use-package "SOCKET")
29     (use-package "GRAY"))
30    
31 wjenkner 1.10 (eval-when (:compile-toplevel :execute)
32     (when (find-package "LINUX")
33     (pushnew :linux *features*)))
34 heller 1.1
35 vsedach 1.3 #+linux
36 wjenkner 1.10 (defmacro with-blocked-signals ((&rest signals) &body body)
37     (ext:with-gensyms ("SIGPROCMASK" ret mask)
38     `(multiple-value-bind (,ret ,mask)
39     (linux:sigprocmask-set-n-save
40     ,linux:SIG_BLOCK
41     ,(do ((sigset (linux:sigset-empty)
42     (linux:sigset-add sigset (the fixnum (pop signals)))))
43     ((null signals) sigset)))
44     (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
45     (unwind-protect
46     (progn ,@body)
47     (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
48 heller 1.24.2.1
49     ;; XXX currently only works in CVS version. 2.32 breaks.
50 heller 1.15 ;; #+linux
51     ;; (defmethod call-without-interrupts (fn)
52     ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
53     ;;
54     ;; #-linux
55 heller 1.12 (defmethod call-without-interrupts (fn)
56     (funcall fn))
57 vsedach 1.3
58 heller 1.12 #+unix (defmethod getpid () (system::program-id))
59     #+win32 (defmethod getpid () (or (system::getenv "PID") -1))
60 vsedach 1.3 ;; the above is likely broken; we need windows NT users!
61 heller 1.1
62 heller 1.21 (defimplementation lisp-implementation-type-name ()
63     "clisp")
64    
65 wjenkner 1.4
66 heller 1.1 ;;; TCP Server
67    
68 heller 1.17 (defimplementation create-socket (host port)
69     (declare (ignore host))
70 heller 1.8 (socket:socket-server port))
71 lgorrie 1.7
72 wjenkner 1.14 (defimplementation local-port (socket)
73 heller 1.8 (socket:socket-server-port socket))
74 vsedach 1.5
75 wjenkner 1.14 (defimplementation close-socket (socket)
76 heller 1.8 (socket:socket-server-close socket))
77 vsedach 1.5
78 wjenkner 1.14 (defimplementation accept-connection (socket)
79 heller 1.8 (socket:socket-accept socket
80     :buffered nil ;; XXX should be t
81     :element-type 'character
82     :external-format (ext:make-encoding
83     :charset 'charset:iso-8859-1
84     :line-terminator :unix)))
85 vsedach 1.3
86     ;;; Swank functions
87 heller 1.1
88 heller 1.24.2.1 (defimplementation arglist (fname)
89     (ext:arglist fname))
90 heller 1.1
91 wjenkner 1.14 (defimplementation macroexpand-all (form)
92 heller 1.1 (ext:expand-form form))
93    
94 wjenkner 1.14 (defimplementation describe-symbol-for-emacs (symbol)
95 heller 1.1 "Return a plist describing SYMBOL.
96     Return NIL if the symbol is unbound."
97     (let ((result ()))
98     (labels ((doc (kind)
99     (or (documentation symbol kind) :not-documented))
100     (maybe-push (property value)
101     (when value
102     (setf result (list* property value result)))))
103     (when (fboundp symbol)
104     (if (macro-function symbol)
105     (setf (getf result :macro) (doc 'function))
106 heller 1.24.2.1 (setf (getf result :function) (doc 'function))))
107 heller 1.1 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
108     (maybe-push :class (when (find-class symbol nil)
109     (doc 'type))) ;this should be fixed
110     result)))
111    
112 heller 1.24.2.1 (defimplementation describe-definition (symbol namespace)
113     (ecase namespace
114     (:variable (describe symbol))
115     (:macro (describe (macro-function symbol)))
116     (:function (describe (symbol-function symbol)))
117     (:class (describe (find-class symbol)))))
118    
119 heller 1.1 (defun fspec-pathname (symbol &optional type)
120     (declare (ignore type))
121     (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
122     (if (and path
123     (member (pathname-type path)
124     custom:*compiled-file-types* :test #'string=))
125     (loop
126     for suffix in custom:*source-file-types*
127     thereis (make-pathname :defaults path :type suffix))
128     path)))
129    
130     (defun find-multiple-definitions (fspec)
131     (list `(,fspec t)))
132 heller 1.24.2.1
133 heller 1.1 (defun find-definition-in-file (fspec type file)
134     (declare (ignore fspec type file))
135     ;; FIXME
136     0)
137    
138 heller 1.24.2.1 (defun find-fspec-location (fspec type)
139     (let ((file (fspec-pathname fspec type)))
140     (etypecase file
141     (pathname
142     (let ((start (find-definition-in-file fspec type file)))
143 heller 1.24.2.2 (multiple-value-bind (truename c) (ignore-errors (truename file))
144     (cond (truename
145     (make-location (list :file (namestring truename))
146     (list :function-name (string fspec))))
147     (t (list :error (princ-to-string c)))))))
148 heller 1.24.2.1 ((member :top-level)
149     (list :error (format nil "Defined at toplevel: ~A" fspec)))
150     (null
151     (list :error (format nil "Unkown source location for ~A" fspec))))))
152    
153 heller 1.1 (defun fspec-source-locations (fspec)
154     (let ((defs (find-multiple-definitions fspec)))
155 heller 1.24.2.1 (loop for (fspec type) in defs
156     collect (list fspec (find-fspec-location fspec type)))))
157    
158    
159     (defimplementation find-definitions (name)
160     (loop for location in (fspec-source-locations name)
161     collect (list name location)))
162 heller 1.1
163     (defvar *sldb-topframe*)
164     (defvar *sldb-botframe*)
165     (defvar *sldb-source*)
166     (defvar *sldb-debugmode* 4)
167    
168 wjenkner 1.14 (defimplementation call-with-debugging-environment (debugger-loop-fn)
169 heller 1.1 (let* ((sys::*break-count* (1+ sys::*break-count*))
170     (sys::*driver* debugger-loop-fn)
171     (sys::*fasoutput-stream* nil)
172     ;;; (sys::*frame-limit1* (sys::frame-limit1 43))
173     (sys::*frame-limit1* (sys::frame-limit1 0))
174     ;;; (sys::*frame-limit2* (sys::frame-limit2))
175     (sys::*debug-mode* *sldb-debugmode*)
176     (*sldb-topframe*
177     (sys::frame-down-1
178     (sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*)
179     sys::*debug-mode*))
180 heller 1.24.2.1 (*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*)))
181 heller 1.1 (funcall debugger-loop-fn)))
182    
183     (defun nth-frame (index)
184     (loop for frame = *sldb-topframe* then (sys::frame-up-1 frame
185     sys::*debug-mode*)
186     repeat index
187     never (eq frame *sldb-botframe*)
188 heller 1.15 finally (return frame)))
189 heller 1.1
190 heller 1.24.2.1 (defimplementation compute-backtrace (start end)
191 heller 1.1 (let ((end (or end most-positive-fixnum)))
192     (loop for f = (nth-frame start)
193     then (sys::frame-up-1 f sys::*debug-mode*)
194     for i from start below end
195     until (eq f *sldb-botframe*)
196     collect f)))
197    
198 heller 1.24.2.1 (defimplementation print-frame (frame stream)
199     (write-string (string-left-trim '(#\Newline)
200     (with-output-to-string (stream)
201     (sys::describe-frame stream frame)))
202     stream))
203 heller 1.1
204 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
205 heller 1.1 (sys::eval-at (nth-frame frame-number) form))
206    
207 wjenkner 1.14 (defimplementation frame-locals (frame-number)
208 heller 1.1 (let* ((frame (nth-frame frame-number))
209     (frame-env (sys::eval-at frame '(sys::the-environment))))
210     (append
211     (frame-do-venv frame (svref frame-env 0))
212     (frame-do-fenv frame (svref frame-env 1))
213     (frame-do-benv frame (svref frame-env 2))
214     (frame-do-genv frame (svref frame-env 3))
215     (frame-do-denv frame (svref frame-env 4)))))
216    
217     ;; Interpreter-Variablen-Environment has the shape
218     ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
219    
220     (defun frame-do-venv (frame venv)
221 heller 1.2 (loop for i from 1 below (length venv) by 2
222     as symbol = (svref venv (1- i))
223     and value = (svref venv i)
224 mbaringer 1.24 collect (list :name symbol :id 0
225     :value (if (eq sys::specdecl value)
226     ;; special variable
227     (sys::eval-at frame symbol)
228     ;; lexical variable or symbol macro
229     value))))
230 heller 1.1
231     (defun frame-do-fenv (frame fenv)
232     (declare (ignore frame fenv))
233     nil)
234    
235     (defun frame-do-benv (frame benv)
236     (declare (ignore frame benv))
237     nil)
238    
239     (defun frame-do-genv (frame genv)
240     (declare (ignore frame genv))
241     nil)
242    
243     (defun frame-do-denv (frame denv)
244     (declare (ignore frame denv))
245     nil)
246    
247 wjenkner 1.14 (defimplementation frame-catch-tags (index)
248 heller 1.1 (declare (ignore index))
249     nil)
250    
251 wjenkner 1.14 (defimplementation return-from-frame (index form)
252 heller 1.24.2.1 (sys::return-from-eval-frame (nth-frame index) form))
253 wjenkner 1.14
254     (defimplementation restart-frame (index)
255     (sys::redo-eval-frame (nth-frame index)))
256    
257     (defimplementation frame-source-location-for-emacs (index)
258 heller 1.1 (list :error (format nil "Cannot find source for frame: ~A"
259     (nth-frame index))))
260    
261 wjenkner 1.16 ;;; Profiling
262    
263     (defimplementation profile (fname)
264     (eval `(mon:monitor ,fname))) ;monitor is a macro
265    
266     (defimplementation profiled-functions ()
267     mon:*monitored-functions*)
268    
269     (defimplementation unprofile (fname)
270     (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
271    
272     (defimplementation unprofile-all ()
273     (mon:unmonitor))
274    
275     (defimplementation profile-report ()
276     (mon:report-monitoring))
277    
278     (defimplementation profile-reset ()
279     (mon:reset-all-monitoring))
280    
281     (defimplementation profile-package (package callers-p methods)
282     (declare (ignore callers-p methods))
283     (mon:monitor-all package))
284 heller 1.1
285     ;;; Handle compiler conditions (find out location of error etc.)
286    
287     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
288     "Pass ARGS to COMPILE-FILE, send the compiler notes to
289     *STANDARD-INPUT* and frob them in BODY."
290     `(let ((*error-output* (make-string-output-stream))
291     (*compile-verbose* t))
292     (multiple-value-prog1
293 vsedach 1.6 (compile-file ,@args)
294     (handler-case
295 heller 1.1 (with-input-from-string
296 vsedach 1.6 (*standard-input* (get-output-stream-string *error-output*))
297     ,@body)
298     (sys::simple-end-of-file () nil)))))
299 heller 1.1
300 heller 1.24.2.1 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
301     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
302     (defvar *orig-c-error* (symbol-function 'system::c-error))
303     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
304    
305     (defmacro dynamic-flet (names-functions &body body)
306     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
307     Temporary the symbol slot of NAME in the dynamic extend of BODY to FUNCTION."
308     `(ext:letf* ,(loop for (name function) in names-functions
309     collect `((symbol-function ',name) ,function))
310     ,@body))
311    
312     (defun compiler-note-location ()
313     "Return the current compiler location of the compiler."
314     (let ((lineno1 sys::*compile-file-lineno1*)
315     (lineno2 sys::*compile-file-lineno2*)
316     (file sys::*compile-file-truename*))
317     (cond ((and file lineno1 lineno2)
318     `(:location (:file ,(namestring file)) (:line ,lineno1)))
319     (*buffer-name*
320     `(:location (:buffer ,*buffer-name*) (:position ,*buffer-offset*)))
321     (t
322     (list :error "No error location available")))))
323    
324     (defun signal-compiler-warning (cstring args severity orig-fn)
325     (signal (make-condition 'compiler-condition
326     :severity severity
327     :message (apply #'format nil cstring args)
328     :location (compiler-note-location)))
329     (apply orig-fn cstring args))
330    
331     (defun c-warn (cstring &rest args)
332     (signal-compiler-warning cstring args :warning *orig-c-warn*))
333    
334     (defun c-style-warn (cstring &rest args)
335     (dynamic-flet ((sys::c-warn *orig-c-warn*))
336     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
337    
338     (defun c-error (cstring &rest args)
339     (signal-compiler-warning cstring args :error *orig-c-error*))
340    
341 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
342 heller 1.24.2.1 (handler-bind ((warning #'handle-notification-condition))
343     (dynamic-flet ((system::c-warn #'c-warn)
344     (system::c-style-warn #'c-style-warn)
345     (system::c-error #'c-error))
346     (funcall function))))
347 heller 1.1
348     (defun handle-notification-condition (condition)
349     "Handle a condition caused by a compiler warning."
350 heller 1.24.2.1 (signal (make-condition 'compiler-condition
351     :original-condition condition
352     :severity :warning
353     :message (princ-to-string condition)
354     :location (compiler-note-location))))
355 heller 1.1
356     (defvar *buffer-name* nil)
357     (defvar *buffer-offset*)
358    
359 heller 1.24.2.1 (defimplementation swank-compile-file (filename load-p)
360 heller 1.1 (with-compilation-hooks ()
361 heller 1.24.2.1 (with-compilation-unit ()
362     (let ((fasl-file (compile-file filename)))
363     (when (and load-p fasl-file)
364     (load fasl-file))
365     nil))))
366 heller 1.1
367 heller 1.24.2.1 (defimplementation swank-compile-string (string &key buffer position)
368 heller 1.1 (with-compilation-hooks ()
369 heller 1.24.2.1 (let ((*buffer-name* buffer)
370 heller 1.1 (*buffer-offset* position))
371 heller 1.24.2.1 (funcall (compile nil (read-from-string
372     (format nil "(CL:LAMBDA () ~A)" string)))))))
373 heller 1.1
374     ;;; Portable XREF from the CMU AI repository.
375    
376     (setq xref::*handle-package-forms* '(cl:in-package))
377    
378 heller 1.24.2.1 (defmacro defxref (name function)
379     `(defimplementation ,name (name)
380     (xref-results (,function name))))
381    
382     (defxref who-calls xref:list-callers)
383     (defxref who-references xref:list-readers)
384     (defxref who-binds xref:list-setters)
385     (defxref who-sets xref:list-setters)
386     (defxref list-callers xref:list-callers)
387     (defxref list-callees xref:list-callees)
388 heller 1.1
389 heller 1.24.2.1 (defun xref-results (fspecs)
390 heller 1.1 (let ((xrefs '()))
391     (dolist (fspec fspecs)
392     (dolist (location (fspec-source-locations fspec))
393 heller 1.24.2.1 (push (list fspec location) xrefs)))
394     xrefs))
395 heller 1.1
396     (when (find-package :swank-loader)
397     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
398     (lambda ()
399     (let ((home (user-homedir-pathname)))
400     (and (ext:probe-directory home)
401     (probe-file (format nil "~A/.swank.lisp"
402     (namestring (truename home)))))))))
403    
404     ;; Don't set *debugger-hook* to nil on break.
405     (ext:without-package-lock ()
406     (defun break (&optional (format-string "Break") &rest args)
407     (if (not sys::*use-clcs*)
408     (progn
409     (terpri *error-output*)
410     (apply #'format *error-output*
411     (concatenate 'string "*** - " format-string)
412     args)
413     (funcall ext:*break-driver* t))
414     (let ((condition
415     (make-condition 'simple-condition
416     :format-control format-string
417     :format-arguments args))
418     ;;(*debugger-hook* nil)
419     ;; Issue 91
420     )
421     (ext:with-restarts
422     ((CONTINUE
423     :report (lambda (stream)
424     (format stream (sys::TEXT "Return from ~S loop")
425     'break))
426     ()))
427     (with-condition-restarts condition (list (find-restart 'CONTINUE))
428     (invoke-debugger condition)))))
429     nil))
430 heller 1.23
431     ;;; Inspecting
432    
433     (defmethod inspected-parts (o)
434     (let* ((*print-array* nil) (*print-pretty* t)
435     (*print-circle* t) (*print-escape* t)
436     (*print-lines* custom:*inspect-print-lines*)
437     (*print-level* custom:*inspect-print-level*)
438     (*print-length* custom:*inspect-print-length*)
439     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
440     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
441     (*package* tmp-pack)
442     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
443     (let ((inspection (sys::inspect-backend o)))
444     (values (format nil "~S~% ~A~{~%~A~}" o
445     (sys::insp-title inspection)
446     (sys::insp-blurb inspection))
447     (let ((count (sys::insp-num-slots inspection))
448     (pairs '()))
449     (dotimes (i count)
450     (multiple-value-bind (value name)
451     (funcall (sys::insp-nth-slot inspection) i)
452 heller 1.24.2.1 (push (cons (princ-to-string (or name i)) value)
453 heller 1.23 pairs)))
454     (nreverse pairs))))))
455 heller 1.1
456     ;;; Local Variables:
457     ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
458 heller 1.24.2.1 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
459 heller 1.1 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5