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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5