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

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Sat Aug 28 02:27:08 2004 UTC (9 years, 7 months ago) by pseibel
Branch: MAIN
Changes since 1.9: +2 -1 lines
Adding directory argument to swank-compile-string.
1 heller 1.1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2     ;;;
3     ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4     ;;;
5 asimon 1.9 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 asimon 1.9 ;;; are disclaimed.
9 heller 1.1 ;;;
10    
11     (in-package :swank-backend)
12    
13    
14     (eval-when (:compile-toplevel :load-toplevel :execute)
15     (require :collect) ;just so that it doesn't spoil the flying letters
16     (require :gray-streams)
17     (require :pprint)
18     )
19    
20     (import
21     '(gs:fundamental-character-output-stream
22     gs:stream-write-char
23     gs:stream-force-output
24     gs:fundamental-character-input-stream
25     gs:stream-read-char
26     gs:stream-listen
27     gs:stream-unread-char
28     gs:stream-clear-input
29     gs:stream-line-column
30     gs:stream-read-char-no-hang
31     ))
32    
33     ;;;; TCP Server
34    
35    
36     (defimplementation preferred-communication-style ()
37     :spawn)
38    
39    
40    
41     (defimplementation create-socket (host port)
42     (ext:make-server-socket port))
43    
44    
45     (defimplementation local-port (socket)
46     (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
47    
48    
49     (defimplementation close-socket (socket)
50     (ext:server-socket-close socket))
51    
52    
53     (defimplementation accept-connection (socket)
54     (ext:get-socket-stream (ext:socket-accept socket)))
55    
56 heller 1.3 (defimplementation emacs-connected (stream)
57     (declare (ignore stream)))
58 heller 1.1
59     ;;;; Unix signals
60    
61     (defimplementation call-without-interrupts (fn)
62     (funcall fn))
63    
64     ;;there are too many to count
65     (defimplementation getpid ()
66     0)
67    
68     (defimplementation lisp-implementation-type-name ()
69     "armedbear")
70    
71     (defimplementation set-default-directory (directory)
72     (let ((dir (sys::probe-directory directory)))
73     (when dir (setf *default-pathname-defaults* dir))
74     (namestring dir)))
75    
76    
77     ;;;; Misc
78    
79     (defimplementation arglist (symbol)
80     (handler-case (sys::arglist symbol)
81     (simple-error () :not-available)))
82    
83     (defimplementation macroexpand-all (form)
84     (macroexpand form))
85    
86     (defimplementation describe-symbol-for-emacs (symbol)
87     (let ((result '()))
88     (flet ((doc (kind &optional (sym symbol))
89     (or (documentation sym kind) :not-documented))
90     (maybe-push (property value)
91     (when value
92     (setf result (list* property value result)))))
93     (maybe-push
94     :variable (when (boundp symbol)
95     (doc 'variable)))
96     (maybe-push
97     :function (if (fboundp symbol)
98     (doc 'function)))
99     (maybe-push
100     :class (if (find-class symbol nil)
101     (doc 'class)))
102     result)))
103    
104    
105     (defimplementation describe-definition (symbol namespace)
106     (ecase namespace
107     (:variable
108     (describe symbol))
109     ((:function :generic-function)
110     (describe (symbol-function symbol)))
111     (:class
112     (describe (find-class symbol)))))
113    
114     (defimplementation describe-definition (symbol namespace)
115     (ecase namespace
116     (:variable
117     (describe symbol))
118     ((:function :generic-function)
119     (describe (symbol-function symbol)))
120     (:class
121     (describe (find-class symbol)))))
122    
123    
124     ;;;; Debugger
125    
126     (defvar *sldb-topframe*)
127    
128     (defimplementation call-with-debugging-environment (debugger-loop-fn)
129     (let ((*sldb-topframe* (car (ext:backtrace-as-list)) #+nil (excl::int-newest-frame)))
130     (funcall debugger-loop-fn)))
131    
132     (defun nth-frame (index)
133     (nth index (ext:backtrace-as-list)))
134    
135     (defimplementation compute-backtrace (start end)
136     (let ((end (or end most-positive-fixnum)))
137     (subseq (ext:backtrace-as-list) start end)))
138    
139     (defimplementation print-frame (frame stream)
140 asimon 1.9 (pprint frame stream))
141 heller 1.1
142     #+nil
143     (defimplementation frame-locals (index)
144     (let ((frame (nth-frame index)))
145     (loop for i from 0 below (debugger:frame-number-vars frame)
146     collect (list :name (debugger:frame-var-name frame i)
147     :id 0
148     :value (debugger:frame-var-value frame i)))))
149    
150     (defimplementation frame-catch-tags (index)
151     (declare (ignore index))
152     nil)
153    
154     #+nil
155     (defimplementation disassemble-frame (index)
156     (disassemble (debugger:frame-function (nth-frame index))))
157    
158     (defimplementation frame-source-location-for-emacs (index)
159     (list :error (format nil "Cannot find source for frame: ~A"
160     (nth-frame index))))
161    
162     #+nil
163     (defimplementation eval-in-frame (form frame-number)
164     (debugger:eval-form-in-context
165     form
166     (debugger:environment-of-frame (nth-frame frame-number))))
167    
168     #+nil
169     (defimplementation return-from-frame (frame-number form)
170     (let ((frame (nth-frame frame-number)))
171     (multiple-value-call #'debugger:frame-return
172     frame (debugger:eval-form-in-context
173     form
174     (debugger:environment-of-frame frame)))))
175    
176     ;;; XXX doesn't work for frames with arguments
177     #+nil
178     (defimplementation restart-frame (frame-number)
179     (let ((frame (nth-frame frame-number)))
180     (debugger:frame-retry frame (debugger:frame-function frame))))
181    
182     ;;;; Compiler hooks
183    
184     (defvar *buffer-name* nil)
185     (defvar *buffer-start-position*)
186     (defvar *buffer-string*)
187     (defvar *compile-filename*)
188    
189     (defun handle-compiler-warning (condition)
190     #+nil
191     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
192     (signal (make-condition
193     'compiler-condition
194     :original-condition condition
195     :severity :warning
196     :message (format nil "~A" condition)
197     :location (cond (*buffer-name*
198     (make-location
199     (list :buffer *buffer-name*)
200     (list :position *buffer-start-position*)))
201     (loc
202     (destructuring-bind (file . pos) loc
203     (make-location
204     (list :file (namestring (truename file)))
205     (list :position (1+ pos)))))
206     (t
207     (make-location
208     (list :file *compile-filename*)
209     (list :position 1))))))))
210    
211     (defimplementation swank-compile-file (*compile-filename* load-p)
212     (handler-bind ((warning #'handle-compiler-warning))
213     (let ((*buffer-name* nil))
214     (multiple-value-bind (fn warn fail)
215     (compile-file *compile-filename*)
216     (when load-p (unless fail (load fn)))))))
217    
218 pseibel 1.10 (defimplementation swank-compile-string (string &key buffer position directory)
219     (declare (ignore directory))
220 heller 1.1 (handler-bind ((warning #'handle-compiler-warning))
221     (let ((*buffer-name* buffer)
222     (*buffer-start-position* position)
223     (*buffer-string* string))
224     (funcall (compile nil (read-from-string
225     (format nil "(~S () ~A)" 'lambda string)))))))
226    
227     #|
228     ;;;; Definition Finding
229    
230     (defun find-fspec-location (fspec type)
231     (let ((file (excl::fspec-pathname fspec type)))
232     (etypecase file
233     (pathname
234     (let ((start (scm:find-definition-in-file fspec type file)))
235     (make-location (list :file (namestring (truename file)))
236     (if start
237     (list :position (1+ start))
238     (list :function-name (string fspec))))))
239     ((member :top-level)
240     (list :error (format nil "Defined at toplevel: ~A" fspec)))
241     (null
242     (list :error (format nil "Unkown source location for ~A" fspec))))))
243    
244     (defun fspec-definition-locations (fspec)
245     (let ((defs (excl::find-multiple-definitions fspec)))
246     (loop for (fspec type) in defs
247     collect (list fspec (find-fspec-location fspec type)))))
248    
249     (defimplementation find-definitions (symbol)
250     (fspec-definition-locations symbol))
251    
252     |#
253    
254 asimon 1.2 (defun source-location (symbol)
255     (when (ext:source symbol)
256     `(((,symbol)
257     (:location
258     (:file ,(namestring (ext:source-pathname symbol)))
259 asimon 1.9 (:position ,(or (ext:source-file-position symbol) 0) t)
260 asimon 1.2 (:snippet nil))))))
261    
262    
263     (defimplementation find-definitions (symbol)
264     (source-location symbol))
265    
266    
267 heller 1.1 #|
268     Should work (with a patched xref.lisp) but is it any use without find-definitions?
269     ;;;; XREF
270     (setq pxref::*handle-package-forms* '(cl:in-package))
271    
272     (defmacro defxref (name function)
273     `(defimplementation ,name (name)
274     (xref-results (,function name))))
275    
276     (defxref who-calls pxref:list-callers)
277     (defxref who-references pxref:list-readers)
278     (defxref who-binds pxref:list-setters)
279     (defxref who-sets pxref:list-setters)
280     (defxref list-callers pxref:list-callers)
281     (defxref list-callees pxref:list-callees)
282    
283     (defun xref-results (symbols)
284     (let ((xrefs '()))
285     (dolist (symbol symbols)
286     (push (list symbol (fspec-location symbol)) xrefs))
287     xrefs))
288    
289     |#
290    
291     #|
292    
293     ;;;; Inspecting
294    
295     (defmethod inspected-parts (o)
296     (let* ((class (class-of o))
297     (slots (clos:class-slots class)))
298     (values (format nil "~A~% is a ~A" o class)
299     (mapcar (lambda (slot)
300     (let ((name (clos:slot-definition-name slot)))
301     (cons (princ-to-string name)
302     (slot-value o name))))
303     slots))))
304     |#
305     ;;;; Multithreading
306    
307     (defimplementation startup-multiprocessing ()
308     #+nil(mp:start-scheduler))
309    
310     (defimplementation spawn (fn &key name)
311 asimon 1.8 (ext:make-thread (lambda () (funcall fn)) :name name))
312 heller 1.1
313 heller 1.6 (defvar *thread-props-lock* (ext:make-thread-lock))
314    
315     (defvar *thread-props* (make-hash-table) ; should be a weak table
316     "A hashtable mapping threads to a plist.")
317    
318     (defvar *thread-id-counter* 0)
319    
320     (defimplementation thread-id (thread)
321     (ext:with-thread-lock (*thread-props-lock*)
322     (or (getf (gethash thread *thread-props*) 'id)
323     (setf (getf (gethash thread *thread-props*) 'id)
324     (incf *thread-id-counter*)))))
325    
326     (defimplementation find-thread (id)
327     (find id (all-threads)
328 asimon 1.7 :key (lambda (thread)
329 heller 1.6 (getf (gethash thread *thread-props*) 'id))))
330    
331 heller 1.1 (defimplementation thread-name (thread)
332 asimon 1.8 (ext:thread-name thread))
333 heller 1.1
334     (defimplementation thread-status (thread)
335 asimon 1.4 (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
336 heller 1.1
337     (defimplementation make-lock (&key name)
338     (ext:make-thread-lock))
339    
340     (defimplementation call-with-lock-held (lock function)
341     (ext:with-thread-lock (lock) (funcall function)))
342    
343     (defimplementation current-thread ()
344     (ext:current-thread))
345    
346     (defimplementation all-threads ()
347     (copy-list (ext:mapcar-threads #'identity)))
348    
349     (defimplementation interrupt-thread (thread fn)
350     (ext:interrupt-thread thread fn))
351    
352     (defimplementation kill-thread (thread)
353     (ext:destroy-thread thread))
354    
355     (defun mailbox (thread)
356     "Return THREAD's mailbox."
357 heller 1.6 (ext:with-thread-lock (*thread-props-lock*)
358     (or (getf (gethash thread *thread-props*) 'mailbox)
359     (setf (getf (gethash thread *thread-props*) 'mailbox)
360 asimon 1.5 (ext:make-mailbox)))))
361 heller 1.1
362 asimon 1.5 (defimplementation send (thread object)
363     (ext:mailbox-send (mailbox thread) object))
364 heller 1.1
365     (defimplementation receive ()
366 asimon 1.5 (ext:mailbox-read (mailbox (ext:current-thread))))
367 heller 1.1
368     (defimplementation quit-lisp ()
369     (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5