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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5