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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5