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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5