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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5