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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5