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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5