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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5