Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 690 lines (568 sloc) 23.426 kb
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
f912c9c New file.
Helmut Eller authored
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
5 ;;; Created 2003
f912c9c New file.
Helmut Eller authored
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
8 ;;; are disclaimed.
f912c9c New file.
Helmut Eller authored
9 ;;;
10
8052a9e Minor modifications.
Helmut Eller authored
11 (in-package :swank-backend)
12
f912c9c New file.
Helmut Eller authored
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (require :sock)
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
15 (require :process))
aa65d6e Implemented.
Luke Gorrie authored
16
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
17 (import-from :excl *gray-stream-symbols* :swank-backend)
f912c9c New file.
Helmut Eller authored
18
f759e67 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
19 ;;; swank-mop
20
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
21 ;; maybe better change MOP to ACLMOP ?
22 ;; CLOS also works in ACL5. --he
23 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
ff1fa86 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
24
25 (defun swank-mop:slot-definition-documentation (slot)
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
26 (documentation slot t))
f759e67 2004-09-13 Marco Baringer <mb@bese.it>
Marco Baringer authored
27
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
28
fab0b31 Add multiprocessing support.
Helmut Eller authored
29 ;;;; TCP Server
f912c9c New file.
Helmut Eller authored
30
8052a9e Minor modifications.
Helmut Eller authored
31 (defimplementation preferred-communication-style ()
32 :spawn)
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
33
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
34 (defimplementation create-socket (host port)
35 (socket:make-socket :connect :passive :local-port port
36 :local-host host :reuse-address t))
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-emacs...
Helmut Eller authored
37
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
38 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
39 (socket:local-port socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
40
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
41 (defimplementation close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
42 (close socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
43
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
44 (defimplementation accept-connection (socket &key external-format buffering
45 timeout)
46 (declare (ignore buffering timeout))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
47 (let ((ef (or external-format :iso-latin-1-unix))
48 (s (socket:accept-connection socket :wait t)))
49 (set-external-format s ef)
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
50 s))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
51
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
52 (defun find-external-format (coding-system)
53 #+(version>= 6)
2bbbb17 (find-external-format): Fix typo.
Helmut Eller authored
54 (let* ((name (ecase coding-system
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
55 (:iso-latin-1-unix :latin1)
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
56 (:utf-8-unix :utf8)
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
57 (:emacs-mule-unix :emacs-mule))))
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
58 (excl:crlf-base-ef (excl:find-external-format name :try-variant t)))
59 #-(version>= 6)
60 (ecase coding-system
61 (:iso-latin-1-unix :default)))
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
62
63 (defun set-external-format (stream external-format)
2bbbb17 (find-external-format): Fix typo.
Helmut Eller authored
64 (setf (stream-external-format stream)
65 (find-external-format external-format)))
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
66
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
67 (defimplementation format-sldb-condition (c)
68 (princ-to-string c))
69
70 (defimplementation condition-references (c)
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
71 (declare (ignore c))
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
72 '())
73
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
74 (defimplementation call-with-syntax-hooks (fn)
75 (funcall fn))
76
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
77 ;;;; Unix signals
78
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
79 (defimplementation call-without-interrupts (fn)
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
80 (excl:without-interrupts (funcall fn)))
81
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
82 (defimplementation getpid ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
83 (excl::getpid))
84
6827452 (lisp-implementation-type-name): Implement it.
Helmut Eller authored
85 (defimplementation lisp-implementation-type-name ()
86 "allegro")
87
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
88 (defimplementation set-default-directory (directory)
b408600 (set-default-directory): Fix for pathnames without a trailing slash.
Matthias Koeppe authored
89 (let* ((dir (namestring (truename (merge-pathnames directory)))))
90 (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
91 dir))
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
92
167a03c (default-directory, call-with-syntax-hooks): Add implementations as
Helmut Eller authored
93 (defimplementation default-directory ()
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
94 (namestring (excl:current-directory)))
167a03c (default-directory, call-with-syntax-hooks): Add implementations as
Helmut Eller authored
95
fab0b31 Add multiprocessing support.
Helmut Eller authored
96 ;;;; Misc
f912c9c New file.
Helmut Eller authored
97
8052a9e Minor modifications.
Helmut Eller authored
98 (defimplementation arglist (symbol)
d589600 (arglist): Return :not-available if arglist lookup fails with an
Luke Gorrie authored
99 (handler-case (excl:arglist symbol)
100 (simple-error () :not-available)))
8052a9e Minor modifications.
Helmut Eller authored
101
102 (defimplementation macroexpand-all (form)
103 (excl::walk form))
f912c9c New file.
Helmut Eller authored
104
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
105 (defimplementation describe-symbol-for-emacs (symbol)
f912c9c New file.
Helmut Eller authored
106 (let ((result '()))
107 (flet ((doc (kind &optional (sym symbol))
108 (or (documentation sym kind) :not-documented))
109 (maybe-push (property value)
110 (when value
111 (setf result (list* property value result)))))
112 (maybe-push
113 :variable (when (boundp symbol)
114 (doc 'variable)))
115 (maybe-push
116 :function (if (fboundp symbol)
117 (doc 'function)))
118 (maybe-push
119 :class (if (find-class symbol nil)
120 (doc 'class)))
121 result)))
122
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
123 (defimplementation describe-definition (symbol namespace)
124 (ecase namespace
125 (:variable
126 (describe symbol))
127 ((:function :generic-function)
128 (describe (symbol-function symbol)))
129 (:class
130 (describe (find-class symbol)))))
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
131
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
132 (defimplementation make-stream-interactive (stream)
133 (setf (interactive-stream-p stream) t))
134
fab0b31 Add multiprocessing support.
Helmut Eller authored
135 ;;;; Debugger
136
f912c9c New file.
Helmut Eller authored
137 (defvar *sldb-topframe*)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
138
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
139 (defimplementation call-with-debugging-environment (debugger-loop-fn)
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
140 (let ((*sldb-topframe* (find-topframe))
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
141 (excl::*break-hook* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
142 (funcall debugger-loop-fn)))
f912c9c New file.
Helmut Eller authored
143
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
144 (defun find-topframe ()
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
145 (let ((skip-frames 3))
146 (do ((f (excl::int-newest-frame) (next-frame f))
147 (i 0 (1+ i)))
148 ((= i skip-frames) f))))
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
149
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
150 (defun next-frame (frame)
151 (let ((next (excl::int-next-older-frame frame)))
152 (cond ((not next) nil)
153 ((debugger:frame-visible-p next) next)
154 (t (next-frame next)))))
155
f912c9c New file.
Helmut Eller authored
156 (defun nth-frame (index)
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
157 (do ((frame *sldb-topframe* (next-frame frame))
f912c9c New file.
Helmut Eller authored
158 (i index (1- i)))
159 ((zerop i) frame)))
160
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
161 (defimplementation compute-backtrace (start end)
f912c9c New file.
Helmut Eller authored
162 (let ((end (or end most-positive-fixnum)))
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
163 (loop for f = (nth-frame start) then (next-frame f)
f912c9c New file.
Helmut Eller authored
164 for i from start below end
165 while f
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
166 collect f)))
f912c9c New file.
Helmut Eller authored
167
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
168 (defimplementation print-frame (frame stream)
169 (debugger:output-frame stream frame :moderate))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
170
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
171 (defimplementation frame-locals (index)
f912c9c New file.
Helmut Eller authored
172 (let ((frame (nth-frame index)))
173 (loop for i from 0 below (debugger:frame-number-vars frame)
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
174 collect (list :name (debugger:frame-var-name frame i)
f912c9c New file.
Helmut Eller authored
175 :id 0
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
176 :value (debugger:frame-var-value frame i)))))
f912c9c New file.
Helmut Eller authored
177
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
178 (defimplementation frame-var-value (frame var)
179 (let ((frame (nth-frame frame)))
180 (debugger:frame-var-value frame var)))
181
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
182 (defimplementation frame-catch-tags (index)
f912c9c New file.
Helmut Eller authored
183 (declare (ignore index))
184 nil)
185
8052a9e Minor modifications.
Helmut Eller authored
186 (defimplementation disassemble-frame (index)
187 (disassemble (debugger:frame-function (nth-frame index))))
188
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
189 (defimplementation frame-source-location-for-emacs (index)
33236b4 From Matthew Danish:
Luke Gorrie authored
190 (let* ((frame (nth-frame index))
191 (expr (debugger:frame-expression frame))
192 (fspec (first expr)))
193 (second (first (fspec-definition-locations fspec)))))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
194
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
195 (defimplementation eval-in-frame (form frame-number)
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
196 (let ((frame (nth-frame frame-number)))
197 ;; let-bind lexical variables
198 (let ((vars (loop for i below (debugger:frame-number-vars frame)
199 for name = (debugger:frame-var-name frame i)
200 if (symbolp name)
201 collect `(,name ',(debugger:frame-var-value frame i)))))
202 (debugger:eval-form-in-context
203 `(let* ,vars ,form)
204 (debugger:environment-of-frame frame)))))
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
205
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
206 (defimplementation return-from-frame (frame-number form)
207 (let ((frame (nth-frame frame-number)))
208 (multiple-value-call #'debugger:frame-return
209 frame (debugger:eval-form-in-context
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
210 form
211 (debugger:environment-of-frame frame)))))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
212
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
213 (defimplementation restart-frame (frame-number)
214 (let ((frame (nth-frame frame-number)))
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
215 (cond ((debugger:frame-retryable-p frame)
216 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
217 (cdr (debugger:frame-expression frame))))
218 (t "Frame is not retryable"))))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
219
fab0b31 Add multiprocessing support.
Helmut Eller authored
220 ;;;; Compiler hooks
221
f912c9c New file.
Helmut Eller authored
222 (defvar *buffer-name* nil)
223 (defvar *buffer-start-position*)
224 (defvar *buffer-string*)
aa65d6e Implemented.
Luke Gorrie authored
225 (defvar *compile-filename* nil)
f912c9c New file.
Helmut Eller authored
226
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
227 (defun compiler-note-p (object)
228 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
229
230 (defun compiler-undefined-functions-called-warning-p (object)
2bbbb17 (find-external-format): Fix typo.
Helmut Eller authored
231 #+(version>= 6)
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
232 (typep object 'excl:compiler-undefined-functions-called-warning))
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
233
234 (deftype compiler-note ()
235 `(satisfies compiler-note-p))
236
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
237 (defun signal-compiler-condition (&rest args)
238 (signal (apply #'make-condition 'compiler-condition args)))
239
f912c9c New file.
Helmut Eller authored
240 (defun handle-compiler-warning (condition)
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
241 (declare (optimize (debug 3) (speed 0) (space 0)))
242 (cond ((and (not *buffer-name*)
243 (compiler-undefined-functions-called-warning-p condition))
244 (handle-undefined-functions-warning condition))
245 (t
246 (signal-compiler-condition
247 :original-condition condition
248 :severity (etypecase condition
249 (warning :warning)
250 (compiler-note :note))
251 :message (format nil "~A" condition)
252 :location (location-for-warning condition)))))
253
254 (defun location-for-warning (condition)
f912c9c New file.
Helmut Eller authored
255 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
358236a (handle-compiler-warning): Handle undefined-functions warnings by
Helmut Eller authored
256 (cond (*buffer-name*
257 (make-location
258 (list :buffer *buffer-name*)
259 (list :position *buffer-start-position*)))
260 (loc
261 (destructuring-bind (file . pos) loc
262 (make-location
263 (list :file (namestring (truename file)))
264 (list :position (1+ pos)))))
265 (t
266 (list :error "No error location available.")))))
267
268 (defun handle-undefined-functions-warning (condition)
269 (let ((fargs (slot-value condition 'excl::format-arguments)))
9f80540 (handle-undefined-functions-warning): Prevent breakage if the
Helmut Eller authored
270 (loop for (fname . pos-file) in (car fargs) do
271 (loop for (pos file) in pos-file do
272 (signal-compiler-condition
273 :original-condition condition
274 :severity :warning
275 :message (format nil "Undefined function referenced: ~S"
276 fname)
277 :location (make-location (list :file file)
278 (list :position (1+ pos))))))))
f912c9c New file.
Helmut Eller authored
279
aa65d6e Implemented.
Luke Gorrie authored
280 (defimplementation call-with-compilation-hooks (function)
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
281 (handler-bind ((warning #'handle-compiler-warning)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
282 ;;(compiler-note #'handle-compiler-warning)
283 )
aa65d6e Implemented.
Luke Gorrie authored
284 (funcall function)))
285
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
286 (defimplementation swank-compile-file (filename load-p
287 &optional external-format)
aa65d6e Implemented.
Luke Gorrie authored
288 (with-compilation-hooks ()
521e923 (swank-compile-file): New optional argument `external-format'.
Helmut Eller authored
289 (let ((*buffer-name* nil)
290 (*compile-filename* filename)
291 (ef (if external-format
292 (find-external-format external-format)
293 :default)))
294 (compile-file *compile-filename* :load-after-compile load-p
295 :external-format ef))))
f912c9c New file.
Helmut Eller authored
296
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
297 (defun call-with-temp-file (fn)
298 (let ((tmpname (system:make-temp-file-name)))
299 (unwind-protect
300 (with-open-file (file tmpname :direction :output :if-exists :error)
301 (funcall fn file tmpname))
302 (delete-file tmpname))))
303
304 (defun compile-from-temp-file (string)
305 (call-with-temp-file
306 (lambda (stream filename)
307 (write-string string stream)
308 (finish-output stream)
d5c9af3 they are pointless when we are compiling via a temporary file.
Matthias Koeppe authored
309 (let ((binary-filename
310 (excl:without-redefinition-warnings
311 ;; Suppress Allegro's redefinition warnings; they are
312 ;; pointless when we are compiling via a temporary
313 ;; file.
314 (compile-file filename :load-after-compile t))))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
315 (when binary-filename
316 (delete-file binary-filename))))))
317
79c38c6 Adding directory argument to swank-compile-string.
Peter Seibel authored
318 (defimplementation swank-compile-string (string &key buffer position directory)
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
319 ;; We store the source buffer in excl::*source-pathname* as a string
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
320 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
321 ;; the fasl file is corrupted if we use some other datatype.
aa65d6e Implemented.
Luke Gorrie authored
322 (with-compilation-hooks ()
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
323 (let ((*buffer-name* buffer)
f912c9c New file.
Helmut Eller authored
324 (*buffer-start-position* position)
79c38c6 Adding directory argument to swank-compile-string.
Peter Seibel authored
325 (*buffer-string* string)
326 (*default-pathname-defaults*
327 (if directory (merge-pathnames (pathname directory))
328 *default-pathname-defaults*)))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
329 (compile-from-temp-file
330 (format nil "~S ~S~%~A"
331 `(in-package ,(package-name *package*))
332 `(eval-when (:compile-toplevel :load-toplevel)
333 (setq excl::*source-pathname*
6d27ed7 (find-fspec-location): Catch errors in excl:source-file.
Helmut Eller authored
334 ',(format nil "~A;~D" buffer position)))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
335 string)))))
f912c9c New file.
Helmut Eller authored
336
fab0b31 Add multiprocessing support.
Helmut Eller authored
337 ;;;; Definition Finding
338
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
339 (defun fspec-primary-name (fspec)
340 (etypecase fspec
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
341 (symbol fspec)
342 (list (fspec-primary-name (second fspec)))))
343
344 ;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
345 ;; single character, but file-position counts them as two. Here we do
346 ;; our own conversion.
347 (defun count-cr (file pos)
348 (let* ((bufsize 256)
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
349 (type '(unsigned-byte 8))
350 (buf (make-array bufsize :element-type type))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
351 (cr-count 0))
984c411 (accept-connection): Accept :external-format as argument.
Helmut Eller authored
352 (with-open-file (stream file :direction :input :element-type type)
353 (loop for bytes-read = (read-sequence buf stream) do
354 (incf cr-count (count (char-code #\return) buf
355 :end (min pos bytes-read)))
356 (decf pos bytes-read)
357 (when (<= pos 0)
358 (return cr-count))))))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
359
7544734 (find-definition-in-file)
Matthias Koeppe authored
360 (defun find-definition-in-file (fspec type file top-level)
361 (let* ((part
362 (or (scm::find-definition-in-definition-group
363 fspec type (scm:section-file :file file)
364 :top-level top-level)
365 (scm::find-definition-in-definition-group
366 (fspec-primary-name fspec)
367 type (scm:section-file :file file)
368 :top-level top-level)))
369 (start (and part
370 (scm::source-part-start part)))
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
371 (pos (if start
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
372 (list :position (1+ (- start (count-cr file start))))
373 (list :function-name (string (fspec-primary-name fspec))))))
374 (make-location (list :file (namestring (truename file)))
375 pos)))
2ab1edd (find-fspec-location): excl:source-file can return stuff like
Helmut Eller authored
376
377 (defun find-definition-in-buffer (filename)
378 (let ((pos (position #\; filename :from-end t)))
379 (make-location
380 (list :buffer (subseq filename 0 pos))
381 (list :position (parse-integer (subseq filename (1+ pos)))))))
382
7544734 (find-definition-in-file)
Matthias Koeppe authored
383 (defun find-fspec-location (fspec type file top-level)
384 (etypecase file
385 (pathname
386 (find-definition-in-file fspec type file top-level))
387 ((member :top-level)
388 (list :error (format nil "Defined at toplevel: ~A"
389 (fspec->string fspec))))
390 (string
391 (find-definition-in-buffer file))))
4902bdb (find-fspec-location): Include the type of the definition in the
Luke Gorrie authored
392
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
393 (defun fspec->string (fspec)
4902bdb (find-fspec-location): Include the type of the definition in the
Luke Gorrie authored
394 (etypecase fspec
36f4daf (swank-compile-string): Use #\; instead of #\: to separate the
Helmut Eller authored
395 (symbol (let ((*package* (find-package :keyword)))
396 (prin1-to-string fspec)))
397 (list (format nil "(~A ~A)"
398 (prin1-to-string (first fspec))
399 (let ((*package* (find-package :keyword)))
400 (prin1-to-string (second fspec)))))))
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
401
437f909 Remove stupid conflicts.
Helmut Eller authored
402 (defun fspec-definition-locations (fspec)
b909530 (fspec-definition-locations): Handle
Matthias Koeppe authored
403 (cond
404 ((and (listp fspec)
405 (eql (car fspec) :top-level-form))
406 (destructuring-bind (top-level-form file position) fspec
407 (list
408 (list (list nil fspec)
409 (make-location (list :buffer file)
410 (list :position position))))))
411 (t
412 (let ((defs (excl::find-source-file fspec)))
413 (if (null defs)
414 (list
415 (list (list nil fspec)
416 (list :error
417 (format nil "Unknown source location for ~A"
418 (fspec->string fspec)))))
7544734 (find-definition-in-file)
Matthias Koeppe authored
419 (loop for (fspec type file top-level) in defs
b909530 (fspec-definition-locations): Handle
Matthias Koeppe authored
420 collect (list (list type fspec)
421 (find-fspec-location fspec type file top-level))))))))
8052a9e Minor modifications.
Helmut Eller authored
422
423 (defimplementation find-definitions (symbol)
424 (fspec-definition-locations symbol))
fab0b31 Add multiprocessing support.
Helmut Eller authored
425
c2d3f88 Implement changed backend interface and remove references to front end s...
Helmut Eller authored
426 ;;;; XREF
f912c9c New file.
Helmut Eller authored
427
8052a9e Minor modifications.
Helmut Eller authored
428 (defmacro defxref (name relation name1 name2)
429 `(defimplementation ,name (x)
430 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
431
432 (defxref who-calls :calls :wild x)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
433 (defxref calls-who :calls x :wild)
8052a9e Minor modifications.
Helmut Eller authored
434 (defxref who-references :uses :wild x)
435 (defxref who-binds :binds :wild x)
436 (defxref who-macroexpands :macro-calls :wild x)
437 (defxref who-sets :sets :wild x)
438
439 (defun xref-result (fspecs)
440 (loop for fspec in fspecs
441 append (fspec-definition-locations fspec)))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
442
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
443 ;; list-callers implemented by groveling through all fbound symbols.
444 ;; Only symbols are considered. Functions in the constant pool are
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
445 ;; searched recursively. Closure environments are ignored at the
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
446 ;; moment (constants in methods are therefore not found).
447
448 (defun map-function-constants (function fn depth)
449 "Call FN with the elements of FUNCTION's constant pool."
450 (do ((i 0 (1+ i))
451 (max (excl::function-constant-count function)))
452 ((= i max))
453 (let ((c (excl::function-constant function i)))
454 (cond ((and (functionp c)
455 (not (eq c function))
456 (plusp depth))
457 (map-function-constants c fn (1- depth)))
458 (t
459 (funcall fn c))))))
460
ca9bb1b (set-external-format): New function. Use LF as eol mark.
Helmut Eller authored
461 (defun in-constants-p (fun symbol)
462 (map-function-constants fun
463 (lambda (c)
464 (when (eq c symbol)
465 (return-from in-constants-p t)))
466 3))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
467
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
468 (defun function-callers (name)
469 (let ((callers '()))
470 (do-all-symbols (sym)
471 (when (fboundp sym)
472 (let ((fn (fdefinition sym)))
473 (when (in-constants-p fn name)
474 (push sym callers)))))
475 callers))
476
477 (defimplementation list-callers (name)
478 (xref-result (function-callers name)))
479
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
480 (defimplementation list-callees (name)
481 (let ((result '()))
482 (map-function-constants (fdefinition name)
483 (lambda (c)
484 (when (fboundp c)
485 (push c result)))
486 2)
487 (xref-result result)))
488
d5c9af3 they are pointless when we are compiling via a temporary file.
Matthias Koeppe authored
489 ;;;; Profiling
490
491 (defimplementation profile-report ()
492 (prof:show-call-graph))
493
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
494 ;;;; Inspecting
495
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored
496 (defclass acl-inspector (inspector)
497 ())
498
499 (defimplementation make-default-inspector ()
500 (make-instance 'acl-inspector))
501
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
502 (defmethod inspect-for-emacs ((f function) inspector)
503 inspector
0ce7bc2 2004-09-14 Marco Baringer <mb@bese.it>
Marco Baringer authored
504 (values "A function."
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
505 (append
506 (label-value-line "Name" (function-name f))
507 `("Formals" ,(princ-to-string (arglist f)) (:newline))
508 (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
509 (when doc
510 `("Documentation:" (:newline) ,doc))))))
511
512 (defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
513 inspector
514 (values "A value." (allegro-inspect o)))
515
516 (defmethod inspect-for-emacs ((o function) (inspector acl-inspector))
517 inspector
518 (values "A function." (allegro-inspect o)))
519
dc71b6e (inspect-for-emacs): Use the backend specific method to inspect
Helmut Eller authored
520 (defmethod inspect-for-emacs ((o standard-object) (inspector acl-inspector))
521 inspector
1daebc6 (inspect-for-emacs): Fix typo.
Marco Baringer authored
522 (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
dc71b6e (inspect-for-emacs): Use the backend specific method to inspect
Helmut Eller authored
523
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
524 (defun allegro-inspect (o)
525 (loop for (d dd) on (inspect::inspect-ctl o)
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
526 append (frob-allegro-field-def o d)
527 until (eq d dd)))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
528
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
529 (defun frob-allegro-field-def (object def)
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
530 (with-struct (inspect::field-def- name type access) def
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
531 (ecase type
d502794 (find-external-format): Translate :utf-8-unix to :utf8, which Allegro
Helmut Eller authored
532 ((:unsigned-word :unsigned-byte :unsigned-natural
533 :unsigned-long :unsigned-half-long
534 :unsigned-3byte)
971c7b4 (eval-in-frame): Allegro's eval-form-in-context does nothing special
Helmut Eller authored
535 (label-value-line name (inspect::component-ref-v object access type)))
536 ((:lisp :value)
537 (label-value-line name (inspect::component-ref object access)))
538 (:indirect
539 (destructuring-bind (prefix count ref set) access
540 (declare (ignore set prefix))
541 (loop for i below (funcall count object)
542 append (label-value-line (format nil "~A-~D" name i)
543 (funcall ref object i))))))))
5bb5d51 (swank-mop:slot-definition-documentation): ACL 7 says documentation
Helmut Eller authored
544
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
545 ;;;; Multithreading
fab0b31 Add multiprocessing support.
Helmut Eller authored
546
d4e5a85 (startup-multiprocessing): Deleted.
Helmut Eller authored
547 (defimplementation initialize-multiprocessing ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
548 (mp:start-scheduler))
549
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
550 (defimplementation spawn (fn &key name)
68dd370 Removed fwrapper-based code for inheriting "swankiness" to newly
Luke Gorrie authored
551 (mp:process-run-function name fn))
fab0b31 Add multiprocessing support.
Helmut Eller authored
552
12da821 (thread-id, find-thread): New backend function.
Helmut Eller authored
553 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
554 (defvar *thread-id-counter* 0)
555
556 (defimplementation thread-id (thread)
557 (mp:with-process-lock (*id-lock*)
558 (or (getf (mp:process-property-list thread) 'id)
559 (setf (getf (mp:process-property-list thread) 'id)
560 (incf *thread-id-counter*)))))
561
562 (defimplementation find-thread (id)
563 (find id mp:*all-processes*
564 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
565
64ff730 Update for modified thread interface.
Helmut Eller authored
566 (defimplementation thread-name (thread)
567 (mp:process-name thread))
fab0b31 Add multiprocessing support.
Helmut Eller authored
568
64ff730 Update for modified thread interface.
Helmut Eller authored
569 (defimplementation thread-status (thread)
570 (format nil "~A ~D" (mp:process-whostate thread)
571 (mp:process-priority thread)))
fab0b31 Add multiprocessing support.
Helmut Eller authored
572
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
573 (defimplementation make-lock (&key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
574 (mp:make-process-lock :name name))
575
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
576 (defimplementation call-with-lock-held (lock function)
fab0b31 Add multiprocessing support.
Helmut Eller authored
577 (mp:with-process-lock (lock) (funcall function)))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
578
579 (defimplementation current-thread ()
580 mp:*current-process*)
581
582 (defimplementation all-threads ()
64ff730 Update for modified thread interface.
Helmut Eller authored
583 (copy-list mp:*all-processes*))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
584
585 (defimplementation interrupt-thread (thread fn)
586 (mp:process-interrupt thread fn))
587
52dc1fc (kill-thread): Implemented.
Helmut Eller authored
588 (defimplementation kill-thread (thread)
589 (mp:process-kill thread))
590
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
591 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
592
593 (defstruct (mailbox (:conc-name mailbox.))
594 (mutex (mp:make-process-lock :name "process mailbox"))
595 (queue '() :type list))
596
597 (defun mailbox (thread)
598 "Return THREAD's mailbox."
599 (mp:with-process-lock (*mailbox-lock*)
600 (or (getf (mp:process-property-list thread) 'mailbox)
601 (setf (getf (mp:process-property-list thread) 'mailbox)
602 (make-mailbox)))))
603
604 (defimplementation send (thread message)
605 (let* ((mbox (mailbox thread))
606 (mutex (mailbox.mutex mbox)))
cbaae0c (send): Wait a bit if there are already many message in the mailbox.
Helmut Eller authored
607 (mp:process-wait-with-timeout
608 "yielding before sending" 0.1
609 (lambda ()
610 (mp:with-process-lock (mutex)
95e3c25 (send): Fix misplaced parens. (From Bill Clementson)
Helmut Eller authored
611 (< (length (mailbox.queue mbox)) 10))))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
612 (mp:with-process-lock (mutex)
613 (setf (mailbox.queue mbox)
614 (nconc (mailbox.queue mbox) (list message))))))
615
616 (defimplementation receive ()
617 (let* ((mbox (mailbox mp:*current-process*))
618 (mutex (mailbox.mutex mbox)))
619 (mp:process-wait "receive" #'mailbox.queue mbox)
620 (mp:with-process-lock (mutex)
621 (pop (mailbox.queue mbox)))))
9decabc See ChangeLog entry 2004-04-06 Marco Baringer
Marco Baringer authored
622
623 (defimplementation quit-lisp ()
624 (excl:exit 0 :quiet t))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
625
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
626
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
627 ;;Trace implementations
628 ;;In Allegro 7.0, we have:
629 ;; (trace <name>)
630 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
631 ;; (trace ((labels <name> <label-name>)))
632 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
633 ;; <name> can be a normal name or a (setf name)
634
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
635 (defimplementation toggle-trace (spec)
b846225 (toggle-trace): Fix from Antonio Menezes Leitao.
Luke Gorrie authored
636 (ecase (car spec)
637 ((setf)
638 (toggle-trace-aux spec))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
639 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
640 ((setf :defmethod :labels :flet)
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
641 (toggle-trace-aux (process-fspec-for-allegro spec)))
b846225 (toggle-trace): Fix from Antonio Menezes Leitao.
Luke Gorrie authored
642 (:call
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
643 (destructuring-bind (caller callee) (cdr spec)
644 (toggle-trace-aux callee
645 :inside (list (process-fspec-for-allegro caller)))))))
646
647 (defun tracedp (fspec)
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
648 (member fspec (eval '(trace)) :test #'equal))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
649
650 (defun toggle-trace-aux (fspec &rest args)
651 (cond ((tracedp fspec)
652 (eval `(untrace ,fspec))
653 (format nil "~S is now untraced." fspec))
654 (t
655 (eval `(trace (,fspec ,@args)))
656 (format nil "~S is now traced." fspec))))
657
658 (defun toggle-trace-generic-function-methods (name)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
659 (let ((methods (mop:generic-function-methods (fdefinition name))))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
660 (cond ((tracedp name)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
661 (eval `(untrace ,name))
662 (dolist (method methods (format nil "~S is now untraced." name))
663 (excl:funtrace (mop:method-function method))))
664 (t
b846225 (toggle-trace): Fix from Antonio Menezes Leitao.
Luke Gorrie authored
665 (eval `(trace (,name)))
c9f86e2 (toggle-trace): Update tracing code for new interface.
Helmut Eller authored
666 (dolist (method methods (format nil "~S is now traced." name))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
667 (excl:ftrace (mop:method-function method)))))))
668
669 (defun process-fspec-for-allegro (fspec)
670 (cond ((consp fspec)
671 (ecase (first fspec)
73e84b5 (process-fspec-for-allegro, toggle-trace): Handle setf functions.
Helmut Eller authored
672 ((setf) fspec)
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
673 ((:defun :defgeneric) (second fspec))
674 ((:defmethod) `(method ,@(rest fspec)))
18204be (restart-frame): Simplify it a little.
Helmut Eller authored
675 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
676 ,(third fspec)))
677 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
678 ,(third fspec)))))
80d90a0 (toggle-trace-generic-function-methods,
Marco Baringer authored
679 (t
680 fspec)))
b7ebf32 * swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak
Helmut Eller authored
681
682
683 ;;;; Weak hashtables
684
685 (defimplementation make-weak-key-hash-table (&rest args)
686 (apply #'make-hash-table :weak-keys t args))
687
688 (defimplementation make-weak-value-hash-table (&rest args)
689 (apply #'make-hash-table :values :weak args))
Something went wrong with that request. Please try again.