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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.154 - (hide annotations)
Sat Aug 4 23:48:19 2012 UTC (20 months, 1 week ago) by sboukarev
Branch: MAIN
Changes since 1.153: +1 -1 lines
* clean up: (signal (make-condition ...)) => (signal ...)
1 heller 1.79 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
2 heller 1.1 ;;;
3     ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4     ;;;
5 heller 1.60 ;;; Created 2003
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 heller 1.74 ;;; are disclaimed.
9 heller 1.1 ;;;
10    
11 heller 1.21 (in-package :swank-backend)
12    
13 heller 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
14     (require :sock)
15 heller 1.135 (require :process)
16     #+(version>= 8 2)
17     (require 'lldb)
18     )
19    
20 heller 1.79 (import-from :excl *gray-stream-symbols* :swank-backend)
21 heller 1.1
22 mbaringer 1.53 ;;; swank-mop
23    
24 heller 1.60 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
25 mbaringer 1.53
26 mbaringer 1.54 (defun swank-mop:slot-definition-documentation (slot)
27 heller 1.62 (documentation slot t))
28 mbaringer 1.53
29 heller 1.79
30 heller 1.146 ;;;; UTF8
31    
32 heller 1.151 (define-symbol-macro utf8-ef
33     (load-time-value
34     (excl:crlf-base-ef (excl:find-external-format :utf-8))
35     t))
36    
37 heller 1.146 (defimplementation string-to-utf8 (s)
38 heller 1.153 (excl:string-to-octets s :external-format utf8-ef
39     :null-terminate nil))
40 heller 1.146
41     (defimplementation utf8-to-string (u)
42 heller 1.151 (excl:octets-to-string u :external-format utf8-ef))
43 heller 1.146
44    
45 heller 1.8 ;;;; TCP Server
46 heller 1.1
47 heller 1.21 (defimplementation preferred-communication-style ()
48     :spawn)
49 heller 1.12
50 heller 1.148 (defimplementation create-socket (host port &key backlog)
51 heller 1.14 (socket:make-socket :connect :passive :local-port port
52 heller 1.148 :local-host host :reuse-address t
53     :backlog (or backlog 5)))
54 heller 1.5
55 heller 1.10 (defimplementation local-port (socket)
56 heller 1.6 (socket:local-port socket))
57    
58 heller 1.10 (defimplementation close-socket (socket)
59 heller 1.6 (close socket))
60    
61 dcrosher 1.85 (defimplementation accept-connection (socket &key external-format buffering
62     timeout)
63     (declare (ignore buffering timeout))
64 heller 1.94 (let ((s (socket:accept-connection socket :wait t)))
65     (when external-format
66     (setf (stream-external-format s) external-format))
67 heller 1.63 s))
68 heller 1.6
69 heller 1.141 (defimplementation socket-fd (stream)
70     (excl::stream-input-handle stream))
71    
72 heller 1.94 (defvar *external-format-to-coding-system*
73     '((:iso-8859-1
74     "latin-1" "latin-1-unix" "iso-latin-1-unix"
75     "iso-8859-1" "iso-8859-1-unix")
76     (:utf-8 "utf-8" "utf-8-unix")
77     (:euc-jp "euc-jp" "euc-jp-unix")
78     (:us-ascii "us-ascii" "us-ascii-unix")
79     (:emacs-mule "emacs-mule" "emacs-mule-unix")))
80    
81     (defimplementation find-external-format (coding-system)
82     (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
83     *external-format-to-coding-system*)))
84     (and e (excl:crlf-base-ef
85     (excl:find-external-format (car e)
86     :try-variant t)))))
87 heller 1.64
88 heller 1.34 (defimplementation format-sldb-condition (c)
89     (princ-to-string c))
90    
91 heller 1.39 (defimplementation call-with-syntax-hooks (fn)
92     (funcall fn))
93    
94 heller 1.9 ;;;; Unix signals
95    
96 heller 1.10 (defimplementation getpid ()
97 heller 1.8 (excl::getpid))
98 heller 1.6
99 heller 1.15 (defimplementation lisp-implementation-type-name ()
100     "allegro")
101    
102 pseibel 1.28 (defimplementation set-default-directory (directory)
103 mkoeppe 1.86 (let* ((dir (namestring (truename (merge-pathnames directory)))))
104     (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
105 heller 1.66 dir))
106 pseibel 1.28
107 heller 1.35 (defimplementation default-directory ()
108 heller 1.66 (namestring (excl:current-directory)))
109 heller 1.35
110 heller 1.8 ;;;; Misc
111 heller 1.1
112 heller 1.21 (defimplementation arglist (symbol)
113 lgorrie 1.30 (handler-case (excl:arglist symbol)
114     (simple-error () :not-available)))
115 heller 1.21
116     (defimplementation macroexpand-all (form)
117     (excl::walk form))
118 heller 1.1
119 heller 1.10 (defimplementation describe-symbol-for-emacs (symbol)
120 heller 1.1 (let ((result '()))
121     (flet ((doc (kind &optional (sym symbol))
122     (or (documentation sym kind) :not-documented))
123     (maybe-push (property value)
124     (when value
125     (setf result (list* property value result)))))
126     (maybe-push
127     :variable (when (boundp symbol)
128     (doc 'variable)))
129     (maybe-push
130     :function (if (fboundp symbol)
131     (doc 'function)))
132     (maybe-push
133     :class (if (find-class symbol nil)
134     (doc 'class)))
135     result)))
136    
137 heller 1.20 (defimplementation describe-definition (symbol namespace)
138     (ecase namespace
139     (:variable
140     (describe symbol))
141     ((:function :generic-function)
142     (describe (symbol-function symbol)))
143     (:class
144     (describe (find-class symbol)))))
145 heller 1.10
146 heller 1.8 ;;;; Debugger
147    
148 heller 1.1 (defvar *sldb-topframe*)
149 heller 1.4
150 heller 1.10 (defimplementation call-with-debugging-environment (debugger-loop-fn)
151 heller 1.71 (let ((*sldb-topframe* (find-topframe))
152 heller 1.20 (excl::*break-hook* nil))
153 heller 1.4 (funcall debugger-loop-fn)))
154 heller 1.1
155 mkoeppe 1.92 (defimplementation sldb-break-at-start (fname)
156 heller 1.135 ;; :print-before is kind of mis-used but we just want to stuff our
157     ;; break form somewhere. This does not work for setf, :before and
158     ;; :after methods, which need special syntax in the trace call, see
159     ;; ACL's doc/debugging.htm chapter 10.
160 mkoeppe 1.92 (eval `(trace (,fname
161     :print-before
162     ((break "Function start breakpoint of ~A" ',fname)))))
163     `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
164    
165 heller 1.71 (defun find-topframe ()
166 trittweiler 1.125 (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
167     (find-package :swank)))
168 sboukarev 1.143 (top-frame (excl::int-newest-frame (excl::current-thread))))
169 trittweiler 1.125 (loop for frame = top-frame then (next-frame frame)
170     for name = (debugger:frame-name frame)
171     for i from 0
172     when (eq name magic-symbol)
173     return (next-frame frame)
174     until (= i 10) finally (return top-frame))))
175 heller 1.71
176 heller 1.42 (defun next-frame (frame)
177     (let ((next (excl::int-next-older-frame frame)))
178     (cond ((not next) nil)
179     ((debugger:frame-visible-p next) next)
180     (t (next-frame next)))))
181    
182 heller 1.1 (defun nth-frame (index)
183 heller 1.42 (do ((frame *sldb-topframe* (next-frame frame))
184 heller 1.1 (i index (1- i)))
185     ((zerop i) frame)))
186    
187 heller 1.20 (defimplementation compute-backtrace (start end)
188 heller 1.1 (let ((end (or end most-positive-fixnum)))
189 heller 1.42 (loop for f = (nth-frame start) then (next-frame f)
190 heller 1.1 for i from start below end
191 heller 1.117 while f collect f)))
192 heller 1.1
193 heller 1.117 (defimplementation print-frame (frame stream)
194     (debugger:output-frame stream frame :moderate))
195 heller 1.4
196 heller 1.10 (defimplementation frame-locals (index)
197 heller 1.1 (let ((frame (nth-frame index)))
198     (loop for i from 0 below (debugger:frame-number-vars frame)
199 mbaringer 1.19 collect (list :name (debugger:frame-var-name frame i)
200 heller 1.1 :id 0
201 mbaringer 1.19 :value (debugger:frame-var-value frame i)))))
202 heller 1.1
203 heller 1.39 (defimplementation frame-var-value (frame var)
204     (let ((frame (nth-frame frame)))
205     (debugger:frame-var-value frame var)))
206 heller 1.1
207 heller 1.21 (defimplementation disassemble-frame (index)
208 heller 1.135 (let ((frame (nth-frame index)))
209     (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
210     (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
211     (disassemble (debugger:frame-function frame)))))
212 heller 1.21
213 heller 1.128 (defimplementation frame-source-location (index)
214 heller 1.135 (let* ((frame (nth-frame index)))
215     (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
216     (declare (ignore x xx xxx))
217 heller 1.136 (cond (pc
218     #+(version>= 8 2)
219     (pc-source-location fun pc)
220     #-(version>= 8 2)
221     (function-source-location fun))
222     (t ; frames for unbound functions etc end up here
223     (cadr (car (fspec-definition-locations
224     (car (debugger:frame-expression frame))))))))))
225 heller 1.135
226     (defun function-source-location (fun)
227 heller 1.152 (cadr (car (fspec-definition-locations
228     (xref::object-to-function-name fun)))))
229 heller 1.135
230     #+(version>= 8 2)
231     (defun pc-source-location (fun pc)
232     (let* ((debug-info (excl::function-source-debug-info fun)))
233     (cond ((not debug-info)
234     (function-source-location fun))
235     (t
236 heller 1.139 (let* ((code-loc (find-if (lambda (c)
237     (<= (- pc (sys::natural-width))
238     (excl::ldb-code-pc c)
239     pc))
240     debug-info)))
241     (cond ((not code-loc)
242 heller 1.135 (ldb-code-to-src-loc (aref debug-info 0)))
243     (t
244 heller 1.139 (ldb-code-to-src-loc code-loc))))))))
245 heller 1.135
246     #+(version>= 8 2)
247     (defun ldb-code-to-src-loc (code)
248     (let* ((start (excl::ldb-code-start-char code))
249     (func (excl::ldb-code-func code))
250 heller 1.136 (src-file (excl:source-file func)))
251     (cond (start
252     (buffer-or-file-location src-file start))
253 heller 1.135 (t
254     (let* ((debug-info (excl::function-source-debug-info func))
255     (whole (aref debug-info 0))
256     (paths (source-paths-of (excl::ldb-code-source whole)
257     (excl::ldb-code-source code)))
258     (path (longest-common-prefix paths))
259 heller 1.138 (start (excl::ldb-code-start-char whole)))
260     (buffer-or-file
261     src-file
262     (lambda (file)
263     (make-location `(:file ,file)
264     `(:source-path (0 . ,path) ,start)))
265     (lambda (buffer bstart)
266     (make-location `(:buffer ,buffer)
267     `(:source-path (0 . ,path)
268     ,(+ bstart start))))))))))
269    
270 heller 1.135 (defun longest-common-prefix (sequences)
271     (assert sequences)
272     (flet ((common-prefix (s1 s2)
273     (let ((diff-pos (mismatch s1 s2)))
274     (if diff-pos (subseq s1 0 diff-pos) s1))))
275     (reduce #'common-prefix sequences)))
276    
277     (defun source-paths-of (whole part)
278     (let ((result '()))
279     (labels ((walk (form path)
280     (cond ((eq form part)
281     (push (reverse path) result))
282     ((consp form)
283     (loop for i from 0 while (consp form) do
284     (walk (pop form) (cons i path)))))))
285     (walk whole '())
286     (reverse result))))
287 heller 1.4
288 heller 1.10 (defimplementation eval-in-frame (form frame-number)
289 heller 1.73 (let ((frame (nth-frame frame-number)))
290     ;; let-bind lexical variables
291     (let ((vars (loop for i below (debugger:frame-number-vars frame)
292     for name = (debugger:frame-var-name frame i)
293     if (symbolp name)
294     collect `(,name ',(debugger:frame-var-value frame i)))))
295     (debugger:eval-form-in-context
296     `(let* ,vars ,form)
297     (debugger:environment-of-frame frame)))))
298 heller 1.10
299 heller 1.11 (defimplementation return-from-frame (frame-number form)
300     (let ((frame (nth-frame frame-number)))
301     (multiple-value-call #'debugger:frame-return
302     frame (debugger:eval-form-in-context
303 heller 1.20 form
304     (debugger:environment-of-frame frame)))))
305 heller 1.67
306 heller 1.117 (defimplementation frame-restartable-p (frame)
307 heller 1.119 (handler-case (debugger:frame-retryable-p frame)
308     (serious-condition (c)
309     (funcall (read-from-string "swank::background-message")
310     "~a ~a" frame (princ-to-string c))
311     nil)))
312 heller 1.117
313 heller 1.11 (defimplementation restart-frame (frame-number)
314     (let ((frame (nth-frame frame-number)))
315 heller 1.69 (cond ((debugger:frame-retryable-p frame)
316     (apply #'debugger:frame-retry frame (debugger:frame-function frame)
317     (cdr (debugger:frame-expression frame))))
318     (t "Frame is not retryable"))))
319 heller 1.67
320 heller 1.8 ;;;; Compiler hooks
321    
322 heller 1.1 (defvar *buffer-name* nil)
323     (defvar *buffer-start-position*)
324     (defvar *buffer-string*)
325 lgorrie 1.33 (defvar *compile-filename* nil)
326 heller 1.1
327 heller 1.66 (defun compiler-note-p (object)
328     (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
329    
330 trittweiler 1.131 (defun redefinition-p (condition)
331     (and (typep condition 'style-warning)
332     (every #'char-equal "redefin" (princ-to-string condition))))
333    
334 heller 1.66 (defun compiler-undefined-functions-called-warning-p (object)
335     (typep object 'excl:compiler-undefined-functions-called-warning))
336 heller 1.64
337     (deftype compiler-note ()
338     `(satisfies compiler-note-p))
339    
340 trittweiler 1.131 (deftype redefinition ()
341     `(satisfies redefinition-p))
342    
343 heller 1.66 (defun signal-compiler-condition (&rest args)
344 sboukarev 1.154 (apply #'signal 'compiler-condition args))
345 heller 1.66
346 heller 1.1 (defun handle-compiler-warning (condition)
347 heller 1.66 (declare (optimize (debug 3) (speed 0) (space 0)))
348 heller 1.133 (cond ((and (not *buffer-name*)
349 heller 1.66 (compiler-undefined-functions-called-warning-p condition))
350     (handle-undefined-functions-warning condition))
351     (t
352     (signal-compiler-condition
353     :original-condition condition
354     :severity (etypecase condition
355 trittweiler 1.131 (redefinition :redefinition)
356     (style-warning :style-warning)
357     (warning :warning)
358 trittweiler 1.126 (compiler-note :note)
359 trittweiler 1.131 (reader-error :read-error)
360     (error :error))
361 heller 1.66 :message (format nil "~A" condition)
362 trittweiler 1.126 :location (if (typep condition 'reader-error)
363     (location-for-reader-error condition)
364     (location-for-warning condition))))))
365 heller 1.66
366     (defun location-for-warning (condition)
367 heller 1.1 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
368 heller 1.66 (cond (*buffer-name*
369     (make-location
370     (list :buffer *buffer-name*)
371 heller 1.114 (list :offset *buffer-start-position* 0)))
372 heller 1.66 (loc
373     (destructuring-bind (file . pos) loc
374 heller 1.133 (let ((start (cond ((consp pos) ; 8.2 and newer
375     (car pos))
376     (t pos))))
377     (make-location
378     (list :file (namestring (truename file)))
379     (list :position (1+ start))))))
380 heller 1.66 (t
381 sboukarev 1.130 (make-error-location "No error location available.")))))
382 heller 1.66
383 trittweiler 1.126 (defun location-for-reader-error (condition)
384     (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
385     (file (pathname (stream-error-stream condition))))
386     (if (integerp pos)
387     (if *buffer-name*
388     (make-location `(:buffer ,*buffer-name*)
389 heller 1.135 `(:offset ,*buffer-start-position* ,pos))
390 trittweiler 1.126 (make-location `(:file ,(namestring (truename file)))
391     `(:position ,pos)))
392 sboukarev 1.130 (make-error-location "No error location available."))))
393 trittweiler 1.126
394 heller 1.133 ;; TODO: report it as a bug to Franz that the condition's plist
395     ;; slot contains (:loc nil).
396 heller 1.66 (defun handle-undefined-functions-warning (condition)
397     (let ((fargs (slot-value condition 'excl::format-arguments)))
398 heller 1.133 (loop for (fname . locs) in (car fargs) do
399     (dolist (loc locs)
400     (multiple-value-bind (pos file) (ecase (length loc)
401     (2 (values-list loc))
402     (3 (destructuring-bind
403     (start end file) loc
404     (declare (ignore end))
405     (values start file))))
406     (signal-compiler-condition
407     :original-condition condition
408     :severity :warning
409     :message (format nil "Undefined function referenced: ~S"
410     fname)
411     :location (make-location (list :file file)
412     (list :position (1+ pos)))))))))
413    
414 lgorrie 1.33 (defimplementation call-with-compilation-hooks (function)
415 trittweiler 1.126 (handler-bind ((warning #'handle-compiler-warning)
416     (compiler-note #'handle-compiler-warning)
417     (reader-error #'handle-compiler-warning))
418 lgorrie 1.33 (funcall function)))
419 heller 1.1
420 heller 1.124 (defimplementation swank-compile-file (input-file output-file
421 sboukarev 1.132 load-p external-format
422     &key policy)
423     (declare (ignore policy))
424 trittweiler 1.126 (handler-case
425     (with-compilation-hooks ()
426     (let ((*buffer-name* nil)
427     (*compile-filename* input-file))
428     (compile-file *compile-filename*
429     :output-file output-file
430     :load-after-compile load-p
431     :external-format external-format)))
432     (reader-error () (values nil nil t))))
433 heller 1.1
434 heller 1.46 (defun call-with-temp-file (fn)
435     (let ((tmpname (system:make-temp-file-name)))
436     (unwind-protect
437     (with-open-file (file tmpname :direction :output :if-exists :error)
438     (funcall fn file tmpname))
439     (delete-file tmpname))))
440    
441 heller 1.135 (defvar *temp-file-map* (make-hash-table :test #'equal)
442     "A mapping from tempfile names to Emacs buffer names.")
443    
444     (defun compile-from-temp-file (string buffer offset file)
445 heller 1.46 (call-with-temp-file
446     (lambda (stream filename)
447 heller 1.135 (let ((excl:*load-source-file-info* t)
448     (sys:*source-file-types* '(nil)) ; suppress .lisp extension
449     #+(version>= 8 2)
450     (compiler:save-source-level-debug-info-switch t)
451     #+(version>= 8 2)
452     (excl:*load-source-debug-info* t) ; NOTE: requires lldb
453     )
454 heller 1.46 (write-string string stream)
455     (finish-output stream)
456 heller 1.116 (multiple-value-bind (binary-filename warnings? failure?)
457 trittweiler 1.126 (excl:without-redefinition-warnings
458 heller 1.116 ;; Suppress Allegro's redefinition warnings; they are
459     ;; pointless when we are compiling via a temporary
460     ;; file.
461     (compile-file filename :load-after-compile t))
462     (declare (ignore warnings?))
463 heller 1.46 (when binary-filename
464 heller 1.135 (setf (gethash (pathname stream) *temp-file-map*)
465     (list buffer offset file))
466 heller 1.116 (delete-file binary-filename))
467 trittweiler 1.126 (not failure?))))))
468    
469     (defimplementation swank-compile-string (string &key buffer position filename
470     policy)
471     (declare (ignore policy))
472     (handler-case
473     (with-compilation-hooks ()
474     (let ((*buffer-name* buffer)
475     (*buffer-start-position* position)
476     (*buffer-string* string)
477     (*default-pathname-defaults*
478     (if filename
479     (merge-pathnames (pathname filename))
480     *default-pathname-defaults*)))
481 heller 1.135 (compile-from-temp-file string buffer position filename)))
482 heller 1.147 (reader-error () nil)))
483 heller 1.46
484 heller 1.8 ;;;; Definition Finding
485    
486 heller 1.137 (defun buffer-or-file (file file-fun buffer-fun)
487 heller 1.135 (let* ((probe (gethash file *temp-file-map*)))
488 heller 1.137 (cond (probe
489 heller 1.135 (destructuring-bind (buffer start file) probe
490     (declare (ignore file))
491 heller 1.137 (funcall buffer-fun buffer start)))
492     (t (funcall file-fun (namestring (truename file)))))))
493    
494     (defun buffer-or-file-location (file offset)
495     (buffer-or-file file
496     (lambda (filename)
497     (make-location `(:file ,filename)
498     `(:position ,(1+ offset))))
499     (lambda (buffer start)
500     (make-location `(:buffer ,buffer)
501     `(:offset ,start ,offset)))))
502 heller 1.135
503 heller 1.32 (defun fspec-primary-name (fspec)
504     (etypecase fspec
505 heller 1.62 (symbol fspec)
506     (list (fspec-primary-name (second fspec)))))
507 heller 1.135
508 mkoeppe 1.81 (defun find-definition-in-file (fspec type file top-level)
509     (let* ((part
510     (or (scm::find-definition-in-definition-group
511     fspec type (scm:section-file :file file)
512     :top-level top-level)
513     (scm::find-definition-in-definition-group
514     (fspec-primary-name fspec)
515     type (scm:section-file :file file)
516     :top-level top-level)))
517     (start (and part
518     (scm::source-part-start part)))
519 heller 1.60 (pos (if start
520 heller 1.114 (list :position (1+ start))
521 heller 1.62 (list :function-name (string (fspec-primary-name fspec))))))
522     (make-location (list :file (namestring (truename file)))
523     pos)))
524 heller 1.60
525 mkoeppe 1.81 (defun find-fspec-location (fspec type file top-level)
526 sboukarev 1.130 (handler-case
527     (etypecase file
528     (pathname
529 heller 1.135 (let ((probe (gethash file *temp-file-map*)))
530     (cond (probe
531     (destructuring-bind (buffer offset file) probe
532     (declare (ignore file))
533     (make-location `(:buffer ,buffer)
534     `(:offset ,offset 0))))
535     (t
536     (find-definition-in-file fspec type file top-level)))))
537 sboukarev 1.130 ((member :top-level)
538 heller 1.152 (make-error-location "Defined at toplevel: ~A"
539     (fspec->string fspec))))
540 sboukarev 1.130 (error (e)
541     (make-error-location "Error: ~A" e))))
542 lgorrie 1.49
543 heller 1.50 (defun fspec->string (fspec)
544 heller 1.135 (typecase fspec
545 heller 1.50 (symbol (let ((*package* (find-package :keyword)))
546     (prin1-to-string fspec)))
547     (list (format nil "(~A ~A)"
548     (prin1-to-string (first fspec))
549     (let ((*package* (find-package :keyword)))
550 heller 1.135 (prin1-to-string (second fspec)))))
551     (t (princ-to-string fspec))))
552 heller 1.21
553     (defun fspec-definition-locations (fspec)
554 mkoeppe 1.87 (cond
555 sboukarev 1.130 ((and (listp fspec)
556     (eql (car fspec) :top-level-form))
557 sboukarev 1.142 (destructuring-bind (top-level-form file &optional (position 0)) fspec
558 sboukarev 1.130 (declare (ignore top-level-form))
559 heller 1.137 `((,fspec
560     ,(buffer-or-file-location file position)))))
561 sboukarev 1.130 ((and (listp fspec) (eq (car fspec) :internal))
562     (destructuring-bind (_internal next _n) fspec
563     (declare (ignore _internal _n))
564     (fspec-definition-locations next)))
565     (t
566     (let ((defs (excl::find-source-file fspec)))
567     (when (and (null defs)
568     (listp fspec)
569     (string= (car fspec) '#:method))
570     ;; If methods are defined in a defgeneric form, the source location is
571     ;; recorded for the gf but not for the methods. Therefore fall back to
572     ;; the gf as the likely place of definition.
573     (setq defs (excl::find-source-file (second fspec))))
574     (if (null defs)
575     (list
576     (list fspec
577     (make-error-location "Unknown source location for ~A"
578     (fspec->string fspec))))
579 heller 1.133 (loop for (fspec type file top-level) in defs collect
580     (list (list type fspec)
581     (find-fspec-location fspec type file top-level))))))))
582 heller 1.21
583     (defimplementation find-definitions (symbol)
584     (fspec-definition-locations symbol))
585 heller 1.1
586 heller 1.8 ;;;; XREF
587    
588 heller 1.21 (defmacro defxref (name relation name1 name2)
589     `(defimplementation ,name (x)
590     (xref-result (xref:get-relation ,relation ,name1 ,name2))))
591    
592     (defxref who-calls :calls :wild x)
593 heller 1.70 (defxref calls-who :calls x :wild)
594 heller 1.21 (defxref who-references :uses :wild x)
595     (defxref who-binds :binds :wild x)
596     (defxref who-macroexpands :macro-calls :wild x)
597     (defxref who-sets :sets :wild x)
598    
599     (defun xref-result (fspecs)
600     (loop for fspec in fspecs
601     append (fspec-definition-locations fspec)))
602 heller 1.46
603     ;; list-callers implemented by groveling through all fbound symbols.
604     ;; Only symbols are considered. Functions in the constant pool are
605 heller 1.71 ;; searched recursively. Closure environments are ignored at the
606 heller 1.46 ;; moment (constants in methods are therefore not found).
607    
608     (defun map-function-constants (function fn depth)
609     "Call FN with the elements of FUNCTION's constant pool."
610     (do ((i 0 (1+ i))
611     (max (excl::function-constant-count function)))
612     ((= i max))
613     (let ((c (excl::function-constant function i)))
614     (cond ((and (functionp c)
615     (not (eq c function))
616     (plusp depth))
617     (map-function-constants c fn (1- depth)))
618     (t
619     (funcall fn c))))))
620    
621 heller 1.64 (defun in-constants-p (fun symbol)
622     (map-function-constants fun
623     (lambda (c)
624     (when (eq c symbol)
625     (return-from in-constants-p t)))
626     3))
627 heller 1.70
628 heller 1.46 (defun function-callers (name)
629     (let ((callers '()))
630     (do-all-symbols (sym)
631     (when (fboundp sym)
632     (let ((fn (fdefinition sym)))
633     (when (in-constants-p fn name)
634     (push sym callers)))))
635     callers))
636    
637     (defimplementation list-callers (name)
638     (xref-result (function-callers name)))
639 heller 1.4
640 heller 1.70 (defimplementation list-callees (name)
641     (let ((result '()))
642     (map-function-constants (fdefinition name)
643     (lambda (c)
644     (when (fboundp c)
645     (push c result)))
646     2)
647     (xref-result result)))
648    
649 mkoeppe 1.83 ;;;; Profiling
650    
651 heller 1.89 ;; Per-function profiling based on description in
652 heller 1.152 ;; http://www.franz.com/support/documentation/8.0/\
653     ;; doc/runtime-analyzer.htm#data-collection-control-2
654 heller 1.89
655     (defvar *profiled-functions* ())
656     (defvar *profile-depth* 0)
657    
658     (defmacro with-redirected-y-or-n-p (&body body)
659     ;; If the profiler is restarted when the data from the previous
660     ;; session is not reported yet, the user is warned via Y-OR-N-P.
661     ;; As the CL:Y-OR-N-P question is (for some reason) not directly
662     ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
663     ;; overruled.
664 sboukarev 1.144 `(let* ((pkg (find-package :common-lisp))
665 heller 1.89 (saved-pdl (excl::package-definition-lock pkg))
666     (saved-ynp (symbol-function 'cl:y-or-n-p)))
667     (setf (excl::package-definition-lock pkg) nil
668 sboukarev 1.144 (symbol-function 'cl:y-or-n-p)
669     (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
670 heller 1.89 (unwind-protect
671 sboukarev 1.144 (progn ,@body)
672 heller 1.89 (setf (symbol-function 'cl:y-or-n-p) saved-ynp
673     (excl::package-definition-lock pkg) saved-pdl))))
674    
675     (defun start-acl-profiler ()
676     (with-redirected-y-or-n-p
677     (prof:start-profiler :type :time :count t
678     :start-sampling-p nil :verbose nil)))
679     (defun acl-profiler-active-p ()
680     (not (eq (prof:profiler-status :verbose nil) :inactive)))
681    
682     (defun stop-acl-profiler ()
683     (prof:stop-profiler :verbose nil))
684    
685     (excl:def-fwrapper profile-fwrapper (&rest args)
686     ;; Ensures sampling is done during the execution of the function,
687     ;; taking into account recursion.
688     (declare (ignore args))
689     (cond ((zerop *profile-depth*)
690     (let ((*profile-depth* (1+ *profile-depth*)))
691     (prof:start-sampling)
692     (unwind-protect (excl:call-next-fwrapper)
693     (prof:stop-sampling))))
694     (t
695     (excl:call-next-fwrapper))))
696    
697     (defimplementation profile (fname)
698     (unless (acl-profiler-active-p)
699     (start-acl-profiler))
700     (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
701     (push fname *profiled-functions*))
702    
703     (defimplementation profiled-functions ()
704     *profiled-functions*)
705    
706     (defimplementation unprofile (fname)
707     (excl:funwrap fname 'profile-fwrapper)
708     (setq *profiled-functions* (remove fname *profiled-functions*)))
709    
710 mkoeppe 1.83 (defimplementation profile-report ()
711 heller 1.89 (prof:show-flat-profile :verbose nil)
712     (when *profiled-functions*
713     (start-acl-profiler)))
714    
715     (defimplementation profile-reset ()
716     (when (acl-profiler-active-p)
717     (stop-acl-profiler)
718     (start-acl-profiler))
719     "Reset profiling counters.")
720 mkoeppe 1.83
721 heller 1.18 ;;;; Inspecting
722    
723 heller 1.111 (excl:without-redefinition-warnings
724 heller 1.100 (defmethod emacs-inspect ((o t))
725 heller 1.111 (allegro-inspect o)))
726 heller 1.62
727 heller 1.100 (defmethod emacs-inspect ((o function))
728 heller 1.101 (allegro-inspect o))
729 heller 1.62
730 heller 1.100 (defmethod emacs-inspect ((o standard-object))
731 heller 1.101 (allegro-inspect o))
732 heller 1.82
733 heller 1.62 (defun allegro-inspect (o)
734     (loop for (d dd) on (inspect::inspect-ctl o)
735 heller 1.73 append (frob-allegro-field-def o d)
736     until (eq d dd)))
737 heller 1.62
738 heller 1.73 (defun frob-allegro-field-def (object def)
739 heller 1.62 (with-struct (inspect::field-def- name type access) def
740 heller 1.73 (ecase type
741 heller 1.79 ((:unsigned-word :unsigned-byte :unsigned-natural
742 heller 1.145 :unsigned-long :unsigned-half-long
743     :unsigned-3byte :unsigned-long32)
744 heller 1.73 (label-value-line name (inspect::component-ref-v object access type)))
745 heller 1.115 ((:lisp :value :func)
746 heller 1.73 (label-value-line name (inspect::component-ref object access)))
747     (:indirect
748     (destructuring-bind (prefix count ref set) access
749     (declare (ignore set prefix))
750     (loop for i below (funcall count object)
751     append (label-value-line (format nil "~A-~D" name i)
752     (funcall ref object i))))))))
753 mbaringer 1.55
754 heller 1.18 ;;;; Multithreading
755 heller 1.8
756 mbaringer 1.91 (defimplementation initialize-multiprocessing (continuation)
757     (mp:start-scheduler)
758     (funcall continuation))
759 heller 1.8
760 heller 1.10 (defimplementation spawn (fn &key name)
761 lgorrie 1.47 (mp:process-run-function name fn))
762 heller 1.8
763 heller 1.40 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
764     (defvar *thread-id-counter* 0)
765    
766     (defimplementation thread-id (thread)
767     (mp:with-process-lock (*id-lock*)
768     (or (getf (mp:process-property-list thread) 'id)
769     (setf (getf (mp:process-property-list thread) 'id)
770     (incf *thread-id-counter*)))))
771    
772     (defimplementation find-thread (id)
773     (find id mp:*all-processes*
774     :key (lambda (p) (getf (mp:process-property-list p) 'id))))
775    
776 heller 1.13 (defimplementation thread-name (thread)
777     (mp:process-name thread))
778 heller 1.8
779 heller 1.13 (defimplementation thread-status (thread)
780 sboukarev 1.140 (princ-to-string (mp:process-whostate thread)))
781    
782     (defimplementation thread-attributes (thread)
783     (list :priority (mp:process-priority thread)
784     :times-resumed (mp:process-times-resumed thread)))
785 heller 1.8
786 heller 1.10 (defimplementation make-lock (&key name)
787 heller 1.8 (mp:make-process-lock :name name))
788    
789 heller 1.10 (defimplementation call-with-lock-held (lock function)
790 heller 1.8 (mp:with-process-lock (lock) (funcall function)))
791 heller 1.12
792     (defimplementation current-thread ()
793     mp:*current-process*)
794    
795     (defimplementation all-threads ()
796 heller 1.13 (copy-list mp:*all-processes*))
797 heller 1.12
798     (defimplementation interrupt-thread (thread fn)
799     (mp:process-interrupt thread fn))
800    
801 heller 1.16 (defimplementation kill-thread (thread)
802     (mp:process-kill thread))
803    
804 heller 1.12 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
805    
806     (defstruct (mailbox (:conc-name mailbox.))
807 heller 1.107 (lock (mp:make-process-lock :name "process mailbox"))
808     (queue '() :type list)
809 heller 1.108 (gate (mp:make-gate nil)))
810 heller 1.12
811     (defun mailbox (thread)
812     "Return THREAD's mailbox."
813     (mp:with-process-lock (*mailbox-lock*)
814     (or (getf (mp:process-property-list thread) 'mailbox)
815     (setf (getf (mp:process-property-list thread) 'mailbox)
816     (make-mailbox)))))
817    
818     (defimplementation send (thread message)
819 heller 1.107 (let* ((mbox (mailbox thread)))
820     (mp:with-process-lock ((mailbox.lock mbox))
821     (setf (mailbox.queue mbox)
822     (nconc (mailbox.queue mbox) (list message)))
823     (mp:open-gate (mailbox.gate mbox)))))
824 heller 1.12
825 heller 1.110 (defimplementation receive-if (test &optional timeout)
826 heller 1.104 (let ((mbox (mailbox mp:*current-process*)))
827 heller 1.110 (assert (or (not timeout) (eq timeout t)))
828 heller 1.107 (loop
829     (check-slime-interrupts)
830     (mp:with-process-lock ((mailbox.lock mbox))
831     (let* ((q (mailbox.queue mbox))
832     (tail (member-if test q)))
833     (when tail
834     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
835     (return (car tail)))
836     (mp:close-gate (mailbox.gate mbox))))
837 heller 1.110 (when (eq timeout t) (return (values nil t)))
838     (mp:process-wait-with-timeout "receive-if" 0.5
839     #'mp:gate-open-p (mailbox.gate mbox)))))
840 heller 1.104
841 heller 1.150 (let ((alist '())
842     (lock (mp:make-process-lock :name "register-thread")))
843    
844     (defimplementation register-thread (name thread)
845     (declare (type symbol name))
846     (mp:with-process-lock (lock)
847     (etypecase thread
848     (null
849     (setf alist (delete name alist :key #'car)))
850     (mp:process
851     (let ((probe (assoc name alist)))
852     (cond (probe (setf (cdr probe) thread))
853     (t (setf alist (acons name thread alist))))))))
854     nil)
855    
856     (defimplementation find-registered (name)
857     (mp:with-process-lock (lock)
858     (cdr (assoc name alist)))))
859    
860 heller 1.123 (defimplementation set-default-initial-binding (var form)
861 heller 1.149 (push (cons var form)
862     #+(version>= 9 0)
863     excl:*required-thread-bindings*
864     #-(version>= 9 0)
865     excl::required-thread-bindings))
866 heller 1.123
867 mbaringer 1.27 (defimplementation quit-lisp ()
868     (excl:exit 0 :quiet t))
869 mbaringer 1.68
870 heller 1.69
871 mbaringer 1.68 ;;Trace implementations
872     ;;In Allegro 7.0, we have:
873     ;; (trace <name>)
874     ;; (trace ((method <name> <qualifier>? (<specializer>+))))
875     ;; (trace ((labels <name> <label-name>)))
876     ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
877     ;; <name> can be a normal name or a (setf name)
878    
879 heller 1.70 (defimplementation toggle-trace (spec)
880 lgorrie 1.72 (ecase (car spec)
881     ((setf)
882     (toggle-trace-aux spec))
883 heller 1.70 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
884 heller 1.71 ((setf :defmethod :labels :flet)
885 heller 1.70 (toggle-trace-aux (process-fspec-for-allegro spec)))
886 lgorrie 1.72 (:call
887 heller 1.70 (destructuring-bind (caller callee) (cdr spec)
888     (toggle-trace-aux callee
889     :inside (list (process-fspec-for-allegro caller)))))))
890    
891     (defun tracedp (fspec)
892 heller 1.71 (member fspec (eval '(trace)) :test #'equal))
893 heller 1.70
894     (defun toggle-trace-aux (fspec &rest args)
895     (cond ((tracedp fspec)
896     (eval `(untrace ,fspec))
897     (format nil "~S is now untraced." fspec))
898     (t
899     (eval `(trace (,fspec ,@args)))
900     (format nil "~S is now traced." fspec))))
901    
902     (defun toggle-trace-generic-function-methods (name)
903 mbaringer 1.68 (let ((methods (mop:generic-function-methods (fdefinition name))))
904 heller 1.70 (cond ((tracedp name)
905 mbaringer 1.68 (eval `(untrace ,name))
906     (dolist (method methods (format nil "~S is now untraced." name))
907     (excl:funtrace (mop:method-function method))))
908     (t
909 lgorrie 1.72 (eval `(trace (,name)))
910 heller 1.70 (dolist (method methods (format nil "~S is now traced." name))
911 mbaringer 1.68 (excl:ftrace (mop:method-function method)))))))
912    
913     (defun process-fspec-for-allegro (fspec)
914     (cond ((consp fspec)
915     (ecase (first fspec)
916 heller 1.71 ((setf) fspec)
917 mbaringer 1.68 ((:defun :defgeneric) (second fspec))
918     ((:defmethod) `(method ,@(rest fspec)))
919 heller 1.69 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
920     ,(third fspec)))
921     ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
922     ,(third fspec)))))
923 mbaringer 1.68 (t
924     fspec)))
925 heller 1.88
926    
927     ;;;; Weak hashtables
928    
929     (defimplementation make-weak-key-hash-table (&rest args)
930     (apply #'make-hash-table :weak-keys t args))
931    
932     (defimplementation make-weak-value-hash-table (&rest args)
933     (apply #'make-hash-table :values :weak args))
934 mkoeppe 1.93
935 alendvai 1.95 (defimplementation hash-table-weakness (hashtable)
936     (cond ((excl:hash-table-weak-keys hashtable) :key)
937     ((eq (excl:hash-table-values hashtable) :weak) :value)))
938    
939    
940 mkoeppe 1.93
941     ;;;; Character names
942    
943     (defimplementation character-completion-set (prefix matchp)
944     (loop for name being the hash-keys of excl::*name-to-char-table*
945     when (funcall matchp prefix name)
946     collect (string-capitalize name)))

  ViewVC Help
Powered by ViewVC 1.1.5