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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Fri Jan 9 02:26:10 2004 UTC (10 years, 3 months ago) by wjenkner
Branch: MAIN
CVS Tags: SLIME-0-10
Changes since 1.3: +28 -0 lines
Add methods for GRAY:STREAM-READ-CHAR-NO-HANG and for the CLISP
specific GRAY:STREAM-READ-CHAR-WILL-HANG-P.  This should fix the
behaviour of SYS::READ-FORM.
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     ;;; containing the "SOCKET", "REGEXP", and (optionally) "LINUX"
19     ;;; packages.
20 heller 1.1
21     (in-package "SWANK")
22    
23     (eval-when (:compile-toplevel :load-toplevel :execute)
24     (use-package "SOCKET")
25     (use-package "GRAY"))
26    
27     ;(setq *use-dedicated-output-stream* nil)
28     (setq *start-swank-in-background* nil)
29     ;(setq *redirect-output* nil)
30    
31 vsedach 1.3 #+linux
32 heller 1.1 (defmacro without-interrupts (&body body)
33     `(let ((sigact (linux:signal-action-retrieve linux:SIGINT)))
34     (unwind-protect
35     (progn
36     (linux:set-sigprocmask linux:SIG_BLOCK (linux:sa-mask sigact))
37     ,@body)
38     (linux:set-sigprocmask linux:SIG_UNBLOCK (linux:sa-mask sigact)))))
39    
40 vsedach 1.3 #-linux
41     (defmacro without-interrupts (body)
42     body)
43    
44 heller 1.1 (defun without-interrupts* (fun)
45     (without-interrupts (funcall fun)))
46    
47 vsedach 1.3 #+linux (defslimefun getpid () (linux::getpid))
48     #+unix (defslimefun getpid () (system::program-id))
49     #+win32 (defslimefun getpid () (or (system::getenv "PID") -1))
50     ;; the above is likely broken; we need windows NT users!
51 heller 1.1
52 wjenkner 1.4
53     ;;; Gray streams
54    
55     ;; From swank-gray.lisp.
56    
57     (defclass slime-input-stream (fundamental-character-input-stream)
58     ((buffer :initform "") (index :initform 0)))
59    
60     ;; We have to define an additional method for the sake of the C
61     ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
62     ;; depends.
63    
64     ;; We could make do with either of the two methods below.
65    
66     (defmethod stream-read-char-no-hang ((s slime-input-stream))
67     (with-slots (buffer index) s
68     (when (< index (length buffer))
69     (prog1 (aref buffer index) (incf index)))))
70    
71     ;; This CLISP extension is what listen_char actually calls. The
72     ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
73     ;; more efficient to define it directly.
74    
75     (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
76     (with-slots (buffer index) s
77     (= index (length buffer))))
78    
79    
80 heller 1.1 ;;; TCP Server
81    
82 vsedach 1.3 (defun get-socket-stream (port announce close-socket-p)
83     (let ((socket (socket:socket-server port)))
84     (socket:socket-wait socket 0)
85     (funcall announce (socket:socket-server-port socket))
86     (prog1
87     (socket:socket-accept socket
88     :buffered nil
89     :element-type 'character
90     :external-format (ext:make-encoding
91     :charset 'charset:iso-8859-1
92     :line-terminator :unix))
93     (when close-socket-p
94     (socket:socket-server-close socket)))))
95    
96     (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
97     "Read and process a request from a SWANK client.
98     The request is read from the socket as a sexp and then evaluated."
99 heller 1.1 (catch 'slime-toplevel
100     (with-simple-restart (abort "Return to Slime toplevel.")
101 vsedach 1.3 (handler-case (read-from-emacs)
102     (ext:simple-charset-type-error (err)
103     (format *debug-io* "Wrong slime stream encoding:~%~A" err))
104     (slime-read-error (e)
105     (when *swank-debug-p*
106     (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
107     (close *emacs-io* :abort t)
108     (when *use-dedicated-output-stream*
109     (close *slime-output* :abort t))
110     (throw 'closed-connection
111     (print "Connection to emacs closed" *debug-io*)))))))
112 heller 1.1
113     (defun open-stream-to-emacs (*emacs-io*)
114 vsedach 1.3 "Return an output-stream to Emacs' output buffer."
115     (let* ((listener (socket:socket-server))
116     (port (socket:socket-server-port listener)))
117     (unwind-protect
118     (prog2
119     (eval-in-emacs `(slime-open-stream-to-lisp ,port))
120     (socket:socket-accept listener
121     :buffered t
122     :external-format charset:iso-8859-1
123     :element-type 'character))
124     (socket:socket-server-close listener))))
125    
126     (defun create-swank-server (port &key (announce #'simple-announce-function)
127     reuse-address
128     background
129     (close *close-swank-socket-after-setup*))
130     (declare (ignore reuse-address background))
131     (let* ((emacs (get-socket-stream port announce close))
132     (slime-out (if *use-dedicated-output-stream*
133     (open-stream-to-emacs emacs)
134     (make-instance 'slime-output-stream)))
135     (slime-in (make-instance 'slime-input-stream))
136     (slime-io (make-two-way-stream slime-in slime-out)))
137     (catch 'closed-connection
138     (loop (serve-request emacs slime-out slime-in slime-io)))))
139    
140     ;;; Swank functions
141 heller 1.1
142     (defmethod arglist-string (fname)
143     (declare (type string fname))
144     (multiple-value-bind (function condition)
145     (ignore-errors (values (from-string fname)))
146     (when condition
147     (return-from arglist-string (format nil "(-- ~A)" condition)))
148     (multiple-value-bind (arglist condition)
149     (ignore-errors (values (ext:arglist function)))
150     (cond (condition (format nil "(-- ~A)" condition))
151     (t (format nil "(~{~A~^ ~})" arglist))))))
152    
153     (defmethod macroexpand-all (form)
154     (ext:expand-form form))
155    
156     (defmethod describe-symbol-for-emacs (symbol)
157     "Return a plist describing SYMBOL.
158     Return NIL if the symbol is unbound."
159     (let ((result ()))
160     (labels ((doc (kind)
161     (or (documentation symbol kind) :not-documented))
162     (maybe-push (property value)
163     (when value
164     (setf result (list* property value result)))))
165     (when (fboundp symbol)
166     (if (macro-function symbol)
167     (setf (getf result :macro) (doc 'function))
168     (setf (getf result :function) (doc 'function))))
169     (maybe-push :variable (when (boundp symbol) (doc 'variable)))
170     (maybe-push :class (when (find-class symbol nil)
171     (doc 'type))) ;this should be fixed
172     result)))
173    
174     (defun fspec-pathname (symbol &optional type)
175     (declare (ignore type))
176     (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
177     (if (and path
178     (member (pathname-type path)
179     custom:*compiled-file-types* :test #'string=))
180     (loop
181     for suffix in custom:*source-file-types*
182     thereis (make-pathname :defaults path :type suffix))
183     path)))
184    
185     (defun find-multiple-definitions (fspec)
186     (list `(,fspec t)))
187    
188     (defun find-definition-in-file (fspec type file)
189     (declare (ignore fspec type file))
190     ;; FIXME
191     0)
192    
193     (defun fspec-source-locations (fspec)
194     (let ((defs (find-multiple-definitions fspec)))
195     (let ((locations '()))
196     (loop for (fspec type) in defs do
197     (let ((file (fspec-pathname fspec type)))
198     (etypecase file
199     (pathname
200     (let ((start (find-definition-in-file fspec type file)))
201     (push (make-location
202     (list :file (namestring (truename file)))
203     (if start
204     (list :position (1+ start))
205     (list :function-name (string fspec))))
206     locations)))
207     ((member :top-level)
208     (push (list :error (format nil "Defined at toplevel: ~A"
209     fspec))
210     locations))
211     (null
212     (push (list :error (format nil
213     "Unkown source location for ~A"
214     fspec))
215     locations))
216     )))
217     locations)))
218    
219     (defmethod find-function-locations (symbol-name)
220     (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
221     (cond ((not foundp)
222     (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
223     ((macro-function symbol)
224     (fspec-source-locations symbol))
225     ((special-operator-p symbol)
226     (list (list :error (format nil "~A is a special-operator" symbol))))
227     ((fboundp symbol)
228     (fspec-source-locations symbol))
229     (t (list (list :error
230     (format nil "Symbol not fbound: ~A" symbol-name))))
231     )))
232    
233     (defvar *sldb-topframe*)
234     (defvar *sldb-botframe*)
235     (defvar *sldb-source*)
236     (defvar *sldb-restarts*)
237     (defvar *sldb-debugmode* 4)
238    
239    
240     (defmethod call-with-debugging-environment (debugger-loop-fn)
241     (let* ((sys::*break-count* (1+ sys::*break-count*))
242     (sys::*driver* debugger-loop-fn)
243     (sys::*fasoutput-stream* nil)
244     ;;; (sys::*frame-limit1* (sys::frame-limit1 43))
245     (sys::*frame-limit1* (sys::frame-limit1 0))
246     ;;; (sys::*frame-limit2* (sys::frame-limit2))
247     (sys::*debug-mode* *sldb-debugmode*)
248     (*sldb-topframe*
249     (sys::frame-down-1
250     (sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*)
251     sys::*debug-mode*))
252     (*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*))
253     (*debugger-hook* nil)
254     (*package* *buffer-package*)
255     (*sldb-restarts*
256     (compute-restarts *swank-debugger-condition*))
257     (*print-pretty* nil)
258     (*print-readably* nil))
259     ;;; (*print-level* 3)
260     ;;; (*print-length* 10))
261     (funcall debugger-loop-fn)))
262    
263     (defun format-restarts-for-emacs ()
264     (loop for restart in *sldb-restarts*
265     collect (list (princ-to-string (restart-name restart))
266     (princ-to-string restart))))
267    
268     (defun nth-frame (index)
269     (loop for frame = *sldb-topframe* then (sys::frame-up-1 frame
270     sys::*debug-mode*)
271     repeat index
272     never (eq frame *sldb-botframe*)
273     finally (return frame)));(setq sys::*debug-frame* frame))))
274    
275     (defun compute-backtrace (start end)
276     (let ((end (or end most-positive-fixnum)))
277     (loop for f = (nth-frame start)
278     then (sys::frame-up-1 f sys::*debug-mode*)
279     for i from start below end
280     until (eq f *sldb-botframe*)
281     collect f)))
282    
283     (defmethod backtrace (start-frame-number end-frame-number)
284     (flet ((format-frame (f i)
285 heller 1.2 (print-with-frame-label
286     i (lambda (s)
287     (princ (string-left-trim
288     '(#\Newline)
289     (with-output-to-string (stream)
290     (sys::describe-frame stream f)))
291     s)))))
292 heller 1.1 (loop for i from start-frame-number
293     for f in (compute-backtrace start-frame-number end-frame-number)
294     collect (list i (format-frame f i)))))
295    
296     (defmethod eval-in-frame (form frame-number)
297     (sys::eval-at (nth-frame frame-number) form))
298    
299     (defmethod frame-locals (frame-number)
300     (let* ((frame (nth-frame frame-number))
301     (frame-env (sys::eval-at frame '(sys::the-environment))))
302     (append
303     (frame-do-venv frame (svref frame-env 0))
304     (frame-do-fenv frame (svref frame-env 1))
305     (frame-do-benv frame (svref frame-env 2))
306     (frame-do-genv frame (svref frame-env 3))
307     (frame-do-denv frame (svref frame-env 4)))))
308    
309     ;; Interpreter-Variablen-Environment has the shape
310     ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
311    
312     (defun frame-do-venv (frame venv)
313 heller 1.2 (loop for i from 1 below (length venv) by 2
314     as symbol = (svref venv (1- i))
315     and value = (svref venv i)
316     collect (list :name (to-string symbol) :id 0
317     :value-string (to-string
318     (if (eq sys::specdecl value)
319     ;; special variable
320     (sys::eval-at frame symbol)
321     ;; lexical variable or symbol macro
322     value)))))
323 heller 1.1
324     (defun frame-do-fenv (frame fenv)
325     (declare (ignore frame fenv))
326     nil)
327    
328     (defun frame-do-benv (frame benv)
329     (declare (ignore frame benv))
330     nil)
331    
332     (defun frame-do-genv (frame genv)
333     (declare (ignore frame genv))
334     nil)
335    
336     (defun frame-do-denv (frame denv)
337     (declare (ignore frame denv))
338     nil)
339    
340     (defmethod frame-catch-tags (index)
341     (declare (ignore index))
342     nil)
343    
344     (defmethod frame-source-location-for-emacs (index)
345     (list :error (format nil "Cannot find source for frame: ~A"
346     (nth-frame index))))
347    
348     (defmethod debugger-info-for-emacs (start end)
349 heller 1.2 (list (debugger-condition-for-emacs)
350 heller 1.1 (format-restarts-for-emacs)
351     (backtrace start end)))
352    
353     (defun nth-restart (index)
354     (nth index *sldb-restarts*))
355    
356     (defslimefun invoke-nth-restart (index)
357     (invoke-restart-interactively (nth-restart index)))
358    
359     (defslimefun sldb-abort ()
360     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
361    
362     ;;; Handle compiler conditions (find out location of error etc.)
363    
364     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
365     "Pass ARGS to COMPILE-FILE, send the compiler notes to
366     *STANDARD-INPUT* and frob them in BODY."
367     `(let ((*error-output* (make-string-output-stream))
368     (*compile-verbose* t))
369     (multiple-value-prog1
370     (compile-file ,@args)
371     (with-input-from-string
372     (*standard-input* (get-output-stream-string *error-output*))
373     ,@body))))
374    
375     (defmethod call-with-compilation-hooks (function)
376     (handler-bind ((compiler-condition #'handle-notification-condition))
377     (funcall function)))
378    
379     (defun handle-notification-condition (condition)
380     "Handle a condition caused by a compiler warning."
381     (signal condition))
382    
383     (defvar *buffer-name* nil)
384     (defvar *buffer-offset*)
385    
386     (defvar *compiler-note-line-regexp*
387     (regexp:regexp-compile
388     "^\\(WARNING\\|ERROR\\) .* in lines \\([0-9]\\+\\)..[0-9]\\+ :$"))
389    
390     (defun split-compiler-note-line (line)
391     (multiple-value-bind (all head tail)
392     (regexp:regexp-exec *compiler-note-line-regexp* line)
393     (declare (ignore all))
394     (if head
395     (list (let ((*package* (find-package :keyword)))
396     (read-from-string (regexp:match-string line head)))
397     (read-from-string (regexp:match-string line tail)))
398     (list nil line))))
399    
400     ;;; Ugly but essentially working.
401     ;;; FIXME: I get all notes twice.
402    
403     (defmethod compile-file-for-emacs (filename load-p)
404     (with-compilation-hooks ()
405     (multiple-value-bind (fasl-file w-p f-p)
406     (compile-file-frobbing-notes (filename)
407     (read-line) ;""
408     (read-line) ;"Compiling file ..."
409     (loop
410     with condition
411     for (severity message) = (split-compiler-note-line (read-line))
412     until (and (stringp message) (string= message ""))
413     if severity
414     do (when condition
415     (signal condition))
416     (setq condition
417     (make-condition 'compiler-condition
418     :severity severity
419     :message ""
420     :location `(:location (:file ,filename)
421     (:line ,message))))
422     else do (setf (message condition)
423     (format nil "~a~&~a" (message condition) message))
424     finally (when condition
425     (signal condition))))
426     (declare (ignore w-p))
427     (cond ((and fasl-file (not f-p) load-p)
428     (load fasl-file))
429     (t fasl-file)))))
430    
431     (defmethod compile-string-for-emacs (string &key buffer position)
432     (with-compilation-hooks ()
433     (let ((*package* *buffer-package*)
434     (*buffer-name* buffer)
435     (*buffer-offset* position))
436     (eval (from-string
437     (format nil "(funcall (compile nil '(lambda () ~A)))"
438     string))))))
439    
440     ;;; Portable XREF from the CMU AI repository.
441    
442     (setq xref::*handle-package-forms* '(cl:in-package))
443    
444     (defun lookup-xrefs (finder name)
445     (xref-results-for-emacs (funcall finder (from-string name))))
446    
447     (defslimefun who-calls (function-name)
448     (lookup-xrefs #'xref:list-callers function-name))
449    
450     (defslimefun who-references (variable)
451     (lookup-xrefs #'xref:list-readers variable))
452    
453     (defslimefun who-binds (variable)
454     (lookup-xrefs #'xref:list-setters variable))
455    
456     (defslimefun who-sets (variable)
457     (lookup-xrefs #'xref:list-setters variable))
458    
459     (defslimefun list-callers (symbol-name)
460     (lookup-xrefs #'xref:who-calls symbol-name))
461    
462     (defslimefun list-callees (symbol-name)
463     (lookup-xrefs #'xref:list-callees symbol-name))
464    
465     (defun xref-results-for-emacs (fspecs)
466     (let ((xrefs '()))
467     (dolist (fspec fspecs)
468     (dolist (location (fspec-source-locations fspec))
469     (push (cons (to-string fspec) location) xrefs)))
470     (group-xrefs xrefs)))
471    
472     (when (find-package :swank-loader)
473     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
474     (lambda ()
475     (let ((home (user-homedir-pathname)))
476     (and (ext:probe-directory home)
477     (probe-file (format nil "~A/.swank.lisp"
478     (namestring (truename home)))))))))
479    
480     ;; Don't set *debugger-hook* to nil on break.
481     (ext:without-package-lock ()
482     (defun break (&optional (format-string "Break") &rest args)
483     (if (not sys::*use-clcs*)
484     (progn
485     (terpri *error-output*)
486     (apply #'format *error-output*
487     (concatenate 'string "*** - " format-string)
488     args)
489     (funcall ext:*break-driver* t))
490     (let ((condition
491     (make-condition 'simple-condition
492     :format-control format-string
493     :format-arguments args))
494     ;;(*debugger-hook* nil)
495     ;; Issue 91
496     )
497     (ext:with-restarts
498     ((CONTINUE
499     :report (lambda (stream)
500     (format stream (sys::TEXT "Return from ~S loop")
501     'break))
502     ()))
503     (with-condition-restarts condition (list (find-restart 'CONTINUE))
504     (invoke-debugger condition)))))
505     nil))
506    
507     ;;; Local Variables:
508     ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
509     ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5