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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Tue Jan 20 23:40:48 2004 UTC (10 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.9: +50 -32 lines
Replace defmethod with defimplementation.

(eval-in-frame): Implemented.
1 heller 1.8 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 heller 1.1 ;;;
3     ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4     ;;;
5     ;;; Created 2003, Helmut Eller
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8     ;;; are disclaimed.
9     ;;;
10 heller 1.10 ;;; $Id: swank-allegro.lisp,v 1.10 2004/01/20 23:40:48 heller Exp $
11 heller 1.1 ;;;
12     ;;; This code was written for
13     ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)"
14     ;;;
15    
16     (eval-when (:compile-toplevel :load-toplevel :execute)
17     (require :sock)
18     (require :process))
19    
20     (in-package :swank)
21    
22     (import
23     '(excl:fundamental-character-output-stream
24     excl:stream-write-char
25     excl:stream-force-output
26     excl:fundamental-character-input-stream
27     excl:stream-read-char
28     excl:stream-listen
29     excl:stream-unread-char
30     excl:stream-clear-input
31     excl:stream-line-column
32 heller 1.7 excl:stream-read-char-no-hang
33 heller 1.1 ))
34    
35 heller 1.8 ;;;; TCP Server
36 heller 1.1
37 heller 1.10 (defimplementation create-socket (port)
38 heller 1.6 (socket:make-socket :connect :passive :local-port port :reuse-address t))
39 heller 1.5
40 heller 1.10 (defimplementation local-port (socket)
41 heller 1.6 (socket:local-port socket))
42    
43 heller 1.10 (defimplementation close-socket (socket)
44 heller 1.6 (close socket))
45    
46 heller 1.10 (defimplementation accept-connection (socket)
47 heller 1.6 (socket:accept-connection socket :wait t))
48    
49 heller 1.10 (defimplementation emacs-connected ())
50 heller 1.7
51 heller 1.9 ;;;; Unix signals
52    
53 heller 1.10 (defimplementation call-without-interrupts (fn)
54 heller 1.9 (excl:without-interrupts (funcall fn)))
55    
56 heller 1.10 (defimplementation getpid ()
57 heller 1.8 (excl::getpid))
58 heller 1.6
59 heller 1.8 ;;;; Misc
60 heller 1.1
61 heller 1.10 (defimplementation arglist-string (fname)
62 heller 1.9 (format-arglist fname #'excl:arglist))
63 heller 1.1
64     (defun apropos-symbols (string &optional external-only package)
65     (remove-if (lambda (sym)
66     (or (keywordp sym)
67     (and external-only
68     (not (equal (symbol-package sym) *buffer-package*))
69     (not (symbol-external-p sym)))))
70     (apropos-list string package external-only t)))
71    
72 heller 1.10 (defimplementation describe-symbol-for-emacs (symbol)
73 heller 1.1 (let ((result '()))
74     (flet ((doc (kind &optional (sym symbol))
75     (or (documentation sym kind) :not-documented))
76     (maybe-push (property value)
77     (when value
78     (setf result (list* property value result)))))
79     (maybe-push
80     :variable (when (boundp symbol)
81     (doc 'variable)))
82     (maybe-push
83     :function (if (fboundp symbol)
84     (doc 'function)))
85     (maybe-push
86     :class (if (find-class symbol nil)
87     (doc 'class)))
88     result)))
89    
90 heller 1.10 (defimplementation macroexpand-all (form)
91 heller 1.4 (excl::walk form))
92    
93 heller 1.10 (defimplementation describe-definition (symbol-name type)
94     (let ((symbol (from-string symbol-name)))
95     (ecase type
96     (:variable (print-description-to-string symbol))
97     ((:function :generic-function)
98     (print-description-to-string (symbol-function symbol)))
99     (:class
100     (print-description-to-string (find-class symbol))))))
101    
102 heller 1.8 ;;;; Debugger
103    
104 heller 1.1 (defvar *sldb-topframe*)
105     (defvar *sldb-source*)
106     (defvar *sldb-restarts*)
107 heller 1.4
108 heller 1.10 (defimplementation call-with-debugging-environment (debugger-loop-fn)
109 heller 1.4 (let ((*sldb-topframe* (excl::int-newest-frame))
110     (*debugger-hook* nil)
111     (excl::*break-hook* nil)
112     (*package* *buffer-package*)
113     (*sldb-restarts*
114     (compute-restarts *swank-debugger-condition*))
115     (*print-pretty* nil)
116     (*print-readably* nil)
117     (*print-level* 3)
118     (*print-length* 10))
119     (funcall debugger-loop-fn)))
120 heller 1.1
121     (defun format-restarts-for-emacs ()
122     (loop for restart in *sldb-restarts*
123     collect (list (princ-to-string (restart-name restart))
124     (princ-to-string restart))))
125    
126     (defun nth-frame (index)
127     (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))
128     (i index (1- i)))
129     ((zerop i) frame)))
130    
131     (defun compute-backtrace (start end)
132     (let ((end (or end most-positive-fixnum)))
133     (loop for f = (nth-frame start) then (excl::int-next-older-frame f)
134     for i from start below end
135     while f
136     collect f)))
137    
138 heller 1.10 (defimplementation backtrace (start-frame-number end-frame-number)
139 heller 1.1 (flet ((format-frame (f i)
140 heller 1.5 (print-with-frame-label
141     i (lambda (s) (debugger:output-frame s f :moderate)))))
142 heller 1.1 (loop for i from start-frame-number
143     for f in (compute-backtrace start-frame-number end-frame-number)
144     collect (list i (format-frame f i)))))
145    
146 heller 1.10 (defimplementation debugger-info-for-emacs (start end)
147 heller 1.5 (list (debugger-condition-for-emacs)
148 heller 1.1 (format-restarts-for-emacs)
149     (backtrace start end)))
150    
151     (defun nth-restart (index)
152     (nth index *sldb-restarts*))
153    
154     (defslimefun invoke-nth-restart (index)
155 heller 1.2 (invoke-restart-interactively (nth-restart index)))
156 heller 1.1
157 heller 1.4 (defslimefun sldb-abort ()
158     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
159    
160 heller 1.10 (defimplementation frame-locals (index)
161 heller 1.1 (let ((frame (nth-frame index)))
162     (loop for i from 0 below (debugger:frame-number-vars frame)
163 heller 1.5 collect (list :name (to-string (debugger:frame-var-name frame i))
164 heller 1.1 :id 0
165     :value-string
166     (to-string (debugger:frame-var-value frame i))))))
167    
168 heller 1.10 (defimplementation frame-catch-tags (index)
169 heller 1.1 (declare (ignore index))
170     nil)
171    
172 heller 1.10 (defimplementation frame-source-location-for-emacs (index)
173 heller 1.4 (list :error (format nil "Cannot find source for frame: ~A"
174     (nth-frame index))))
175    
176 heller 1.10 (defimplementation eval-in-frame (form frame-number)
177     (debugger:eval-form-in-context
178     form
179     (debugger:environment-of-frame (nth-frame frame-number))))
180    
181 heller 1.8 ;;;; Compiler hooks
182    
183 heller 1.1 (defvar *buffer-name* nil)
184     (defvar *buffer-start-position*)
185     (defvar *buffer-string*)
186     (defvar *compile-filename*)
187    
188     (defun handle-compiler-warning (condition)
189     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
190     (signal (make-condition
191     'compiler-condition
192     :original-condition condition
193     :severity :warning
194     :message (format nil "~A" condition)
195     :location (cond (*buffer-name*
196     (make-location
197     (list :buffer *buffer-name*)
198     (list :position *buffer-start-position*)))
199     (loc
200     (destructuring-bind (file . pos) loc
201     (make-location
202     (list :file (namestring (truename file)))
203     (list :position (1+ pos)))))
204     (t
205     (make-location
206     (list :file *compile-filename*)
207     (list :position 1))))))))
208    
209 heller 1.10 (defimplementation compile-file-for-emacs (*compile-filename* load-p)
210 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
211     (let ((*buffer-name* nil))
212 heller 1.4 (compile-file *compile-filename* :load-after-compile load-p))))
213 heller 1.1
214 heller 1.10 (defimplementation compile-string-for-emacs (string &key buffer position)
215 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
216     (let ((*package* *buffer-package*)
217     (*buffer-name* buffer)
218     (*buffer-start-position* position)
219     (*buffer-string* string))
220     (eval (from-string
221     (format nil "(funcall (compile nil '(lambda () ~A)))" string))))))
222    
223 heller 1.8 ;;;; Definition Finding
224    
225 heller 1.1 (defun fspec-source-locations (fspec)
226     (let ((defs (excl::find-multiple-definitions fspec)))
227     (let ((locations '()))
228     (loop for (fspec type) in defs do
229     (let ((file (excl::fspec-pathname fspec type)))
230     (etypecase file
231     (pathname
232     (let ((start (scm:find-definition-in-file fspec type file)))
233     (push (make-location
234     (list :file (namestring (truename file)))
235     (if start
236     (list :position (1+ start))
237     (list :function-name (string fspec))))
238     locations)))
239     ((member :top-level)
240     (push (list :error (format nil "Defined at toplevel: ~A"
241     fspec))
242     locations))
243     (null
244     (push (list :error (format nil
245     "Unkown source location for ~A"
246     fspec))
247     locations))
248     )))
249     locations)))
250    
251 heller 1.10 (defimplementation find-function-locations (symbol-name)
252 heller 1.1 (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
253     (cond ((not foundp)
254     (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
255     ((macro-function symbol)
256     (fspec-source-locations symbol))
257     ((special-operator-p symbol)
258     (list (list :error (format nil "~A is a special-operator" symbol))))
259     ((fboundp symbol)
260     (fspec-source-locations symbol))
261     (t (list (list :error
262     (format nil "Symbol not fbound: ~A" symbol-name))))
263     )))
264    
265 heller 1.8 ;;;; XREF
266    
267 heller 1.1 (defun lookup-xrefs (finder name)
268     (xref-results-for-emacs (funcall finder (from-string name))))
269    
270 heller 1.10 (defimplementation who-calls (function-name)
271 heller 1.1 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
272     function-name))
273    
274 heller 1.10 (defimplementation who-references (variable)
275 heller 1.1 (lookup-xrefs (lambda (x) (xref:get-relation :uses :wild x))
276     variable))
277    
278 heller 1.10 (defimplementation who-binds (variable)
279 heller 1.1 (lookup-xrefs (lambda (x) (xref:get-relation :binds :wild x))
280     variable))
281    
282 heller 1.10 (defimplementation who-macroexpands (variable)
283     (lookup-xrefs (lambda (x) (xref:get-relation :macro-calls :wild x))
284     variable))
285    
286     (defimplementation who-sets (variable)
287 heller 1.1 (lookup-xrefs (lambda (x) (xref:get-relation :sets :wild x))
288     variable))
289    
290 heller 1.10 (defimplementation list-callers (name)
291 heller 1.1 (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
292     name))
293    
294 heller 1.10 (defimplementation list-callees (name)
295 heller 1.1 (lookup-xrefs (lambda (x) (xref:get-relation :calls x :wild))
296     name))
297    
298     (defun xref-results-for-emacs (fspecs)
299     (let ((xrefs '()))
300     (dolist (fspec fspecs)
301 heller 1.4 (dolist (location (fspec-source-locations fspec))
302     (push (cons (to-string fspec) location) xrefs)))
303 heller 1.1 (group-xrefs xrefs)))
304 heller 1.4
305 heller 1.8 ;;;; Multiprocessing
306    
307 heller 1.10 (defimplementation startup-multiprocessing ()
308 heller 1.8 (mp:start-scheduler))
309    
310 heller 1.10 (defimplementation spawn (fn &key name)
311 heller 1.8 (mp:process-run-function name fn))
312    
313     ;; XXX: shurtcut
314 heller 1.10 (defimplementation thread-id ()
315 heller 1.8 (mp:process-name mp:*current-process*))
316    
317 heller 1.10 (defimplementation thread-name (thread-id)
318 heller 1.8 thread-id)
319    
320 heller 1.10 (defimplementation make-lock (&key name)
321 heller 1.8 (mp:make-process-lock :name name))
322    
323 heller 1.10 (defimplementation call-with-lock-held (lock function)
324 heller 1.8 (mp:with-process-lock (lock) (funcall function)))

  ViewVC Help
Powered by ViewVC 1.1.5