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

Contents of /slime/swank-scl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Fri Nov 11 23:43:43 2005 UTC (8 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.1: +2 -1 lines
(accept-connection): New argument: buffering.
1 dcrosher 1.1 ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2     ;;;
3     ;;; Scieneer Common Lisp code for SLIME.
4     ;;;
5     ;;; This code has been placed in the Public Domain. All warranties
6     ;;; are disclaimed.
7     ;;;
8    
9     (in-package :swank-backend)
10    
11    
12    
13     ;;; swank-mop
14    
15     (import-swank-mop-symbols :clos '(:slot-definition-documentation
16     :eql-specializer
17     :eql-specializer-object))
18    
19     (defun swank-mop:slot-definition-documentation (slot)
20     (slot-value slot 'documentation))
21    
22     (defun swank-mop:specializer-direct-methods (obj)
23     (declare (ignore obj))
24     nil)
25    
26     (deftype swank-mop:eql-specializer ()
27     '(or kernel:member-type kernel:numeric-type))
28    
29     (defun swank-mop:eql-specializer-object (obj)
30     (etypecase obj
31     (kernel:numeric-type
32     (kernel:type-specifier obj))
33     (kernel:member-type
34     (first (kernel:member-type-members obj)))))
35    
36    
37     ;;;; TCP server
38     ;;;
39     ;;; SCL only supports the :spawn communication style.
40     ;;;
41    
42     (defimplementation preferred-communication-style ()
43     :spawn)
44    
45     (defimplementation create-socket (host port)
46     (let ((addr (resolve-hostname host)))
47     (ext:create-inet-listener port :stream :host addr :reuse-address t)))
48    
49     (defimplementation local-port (socket)
50     (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
51    
52     (defimplementation close-socket (socket)
53     (ext:close-socket (socket-fd socket)))
54    
55 heller 1.2 (defimplementation accept-connection (socket &key external-format buffering)
56     (declare (ignore buffering))
57 dcrosher 1.1 (let ((external-format (or external-format :iso-latin-1-unix)))
58     (make-socket-io-stream (ext:accept-tcp-connection socket)
59     external-format)))
60    
61     ;;;;; Sockets
62    
63     (defun socket-fd (socket)
64     "Return the file descriptor for the socket represented by 'socket."
65     (etypecase socket
66     (fixnum socket)
67     (stream (sys:fd-stream-fd socket))))
68    
69     (defun resolve-hostname (hostname)
70     "Return the IP address of 'hostname as an integer (in host byte-order)."
71     (let ((hostent (ext:lookup-host-entry hostname)))
72     (car (ext:host-entry-addr-list hostent))))
73    
74     (defun find-external-format (coding-system)
75     (case coding-system
76     (:iso-latin-1-unix :iso-8859-1)
77     (:utf-8-unix :utf-8)
78     (t coding-system)))
79    
80     (defun make-socket-io-stream (fd external-format)
81     "Create a new input/output fd-stream for 'fd."
82     (let ((external-format (find-external-format external-format)))
83     (sys:make-fd-stream fd :input t :output t :element-type 'base-char
84     :external-format external-format)))
85    
86    
87     ;;;; Stream handling
88    
89     (defclass slime-input-stream (ext:character-input-stream)
90     ((buffer :initarg :buffer :type string)
91     (index :initarg :index :initform 0 :type fixnum)
92     (position :initarg :position :initform 0 :type integer)
93     (interactive :initarg :interactive :initform nil :type (member nil t))
94     (output-stream :initarg :output-stream :initform nil)
95     (input-fn :initarg :input-fn :type function)
96     ))
97    
98     (defun make-slime-input-stream (input-fn &optional output-stream)
99     (declare (function input-fn))
100     (make-instance 'slime-input-stream
101     :in-buffer (make-string 256)
102     :in-head 0 :in-tail 0
103     :out-buffer ""
104     :buffer "" :index 0
105     :input-fn input-fn
106     :output-stream output-stream))
107    
108     (defmethod print-object ((s slime-input-stream) stream)
109     (print-unreadable-object (s stream :type t)))
110    
111     ;;; input-stream-p inherits from input-stream.
112     ;;; output-stream-p inherits nil.
113    
114     (defmethod ext:stream-listen ((stream slime-input-stream))
115     (let* ((buffer (slot-value stream 'buffer))
116     (index (slot-value stream 'index))
117     (length (length buffer)))
118     (declare (type string buffer)
119     (fixnum index length))
120     (< index length)))
121    
122     (defmethod close ((stream slime-input-stream) &key ((:abort abort) nil))
123     (declare (ignore abort))
124     (when (ext:stream-open-p stream)
125     (setf (ext:stream-open-p stream) nil)
126     (setf (ext:stream-in-buffer stream) " ")
127     t))
128    
129     (defmethod ext:stream-clear-input ((stream slime-input-stream))
130     (let* ((input-buffer (slot-value stream 'buffer))
131     (index (slot-value stream 'index))
132     (input-length (length input-buffer))
133     (available (- input-length index))
134     (position (slot-value stream 'position))
135     (new-position (+ position available)))
136     (declare (type kernel:index index available position new-position))
137     (setf (slot-value stream 'position) new-position))
138     (setf (slot-value stream 'buffer) "")
139     (setf (slot-value stream 'index) 0)
140     nil)
141    
142     ;;; No 'stream-finish-output method.
143     ;;; No 'stream-force-output method.
144     ;;; No 'stream-clear-output method.
145    
146     ;;; stream-element-type inherits from character-stream.
147    
148     ;;; No 'stream-line-length method.
149     ;;; No 'stream-line-column method.
150    
151     ;;; Add the remaining input to the current position.
152     (defmethod file-length ((stream slime-input-stream))
153     (let* ((input-buffer (slot-value stream 'buffer))
154     (index (slot-value stream 'index))
155     (input-length (length input-buffer))
156     (available (- input-length index))
157     (position (slot-value stream 'position))
158     (file-length (+ position available)))
159     (declare (type kernel:index index available position file-length))
160     file-length))
161    
162     (defmethod ext:stream-file-position ((stream slime-input-stream)
163     &optional position)
164     (let ((current-position (slot-value stream 'position)))
165     (declare (type kernel:index current-position))
166     (cond (position
167     ;; Could make an attempt here, but just give up for now.
168     nil)
169     (t
170     current-position))))
171    
172     (defmethod interactive-stream-p ((stream slime-input-stream))
173     (slot-value stream 'interactive))
174    
175     ;;; No 'file-string-length method.
176    
177     (defmethod ext:stream-read-chars ((stream slime-input-stream) buffer
178     start requested waitp)
179     (declare (type simple-string buffer)
180     (type kernel:index start requested))
181     (let* ((input-buffer (slot-value stream 'buffer))
182     (index (slot-value stream 'index))
183     (input-length (length input-buffer))
184     (available (- input-length index))
185     (copy (min available requested)))
186     (declare (string input-buffer)
187     (type kernel:index index available copy))
188     (cond ((plusp copy)
189     (dotimes (i copy)
190     (declare (type kernel:index i))
191     (setf (aref buffer (+ start i)) (aref input-buffer (+ index i))))
192     (incf (slot-value stream 'position) copy)
193     copy)
194     (waitp
195     (let ((output-stream (slot-value stream 'output-stream))
196     (input-fn (slot-value stream 'input-fn)))
197     (declare (type function input-fn))
198     (when output-stream
199     (force-output output-stream))
200     (let ((new-input (funcall input-fn)))
201     (cond ((zerop (length new-input))
202     -1)
203     (t
204     (setf (slot-value stream 'buffer) new-input)
205     (setf (slot-value stream 'index) 0)
206     (ext:stream-read-chars stream buffer start requested waitp))))))
207     (t
208     0))))
209    
210     ;;; Slime output stream.
211    
212     (defclass slime-output-stream (ext:character-output-stream)
213     ((output-fn :initarg :output-fn :type function)
214     (column :initform 0 :type kernel:index)
215     (interactive :initform nil :type (member nil t))
216     (position :initform 0 :type integer)))
217    
218     (defun make-slime-output-stream (output-fn)
219     (declare (function output-fn))
220     (make-instance 'slime-output-stream
221     :in-buffer ""
222     :out-buffer (make-string 256)
223     :output-fn output-fn))
224    
225     (defmethod print-object ((s slime-output-stream) stream)
226     (print-unreadable-object (s stream :type t)))
227    
228     ;;; Use default 'input-stream-p method for 'output-stream which returns 'nil.
229     ;;; Use default 'output-stream-p method for 'output-stream which returns 't.
230    
231     ;;; No 'stream-listen method.
232    
233     (defmethod close ((stream slime-output-stream) &key ((:abort abort) nil))
234     (when (ext:stream-open-p stream)
235     (unless abort
236     (finish-output stream))
237     (setf (ext:stream-open-p stream) nil)
238     (setf (ext:stream-out-buffer stream) " ")
239     t))
240    
241     ;;; No 'stream-clear-input method.
242    
243     (defmethod ext:stream-finish-output ((stream slime-output-stream))
244     nil)
245    
246     (defmethod ext:stream-force-output ((stream slime-output-stream))
247     nil)
248    
249     (defmethod ext:stream-clear-output ((stream slime-output-stream))
250     nil)
251    
252     ;;; Use default 'stream-element-type method for 'character-stream which
253     ;;; returns 'base-char.
254    
255     (defmethod ext:stream-line-length ((stream slime-output-stream))
256     80)
257    
258     (defmethod ext:stream-line-column ((stream slime-output-stream))
259     (slot-value stream 'column))
260    
261     (defmethod file-length ((stream slime-output-stream))
262     (slot-value stream 'position))
263    
264     (defmethod ext:stream-file-position ((stream slime-output-stream)
265     &optional position)
266     (declare (optimize (speed 3)))
267     (cond (position
268     (let* ((current-position (slot-value stream 'position))
269     (target-position (etypecase position
270     ((member :start) 0)
271     ((member :end) current-position)
272     (kernel:index position))))
273     (declare (type kernel:index current-position target-position))
274     (cond ((= target-position current-position)
275     t)
276     ((> target-position current-position)
277     (let ((output-fn (slot-value stream 'output-fn))
278     (fill-size (- target-position current-position)))
279     (declare (function output-fn))
280     (funcall output-fn (make-string fill-size
281     :initial-element #\space))
282     (setf (slot-value stream 'position) target-position))
283     t)
284     (t
285     nil))))
286     (t
287     (slot-value stream 'position))))
288    
289     (defmethod interactive-stream-p ((stream slime-output-stream))
290     (slot-value stream 'interactive))
291    
292     ;;; Use the default 'character-output-stream 'file-string-length method.
293    
294     ;;; stream-write-chars
295     ;;;
296     ;;; The stream out-buffer is typically large enough that there is little point
297     ;;; growing the stream output 'string large than the total size. For typical
298     ;;; usage this reduces consing. As the string grows larger then grow to
299     ;;; reduce the cost of copying strings around.
300     ;;;
301     (defmethod ext:stream-write-chars ((stream slime-output-stream) string start end)
302     (declare (simple-string string)
303     (type kernel:index start end))
304     (declare (optimize (speed 3)))
305     (unless (ext:stream-open-p stream)
306     (error 'kernel:simple-stream-error
307     :stream stream
308     :format-control "Stream closed."))
309     (let* ((string-length (length string))
310     (start (cond ((< start 0) 0)
311     ((> start string-length) string-length)
312     (t start)))
313     (end (cond ((< end start) start)
314     ((> end string-length) string-length)
315     (t end)))
316     (length (- end start))
317     (output-fn (slot-value stream 'output-fn)))
318     (declare (type kernel:index start end length)
319     (type function output-fn))
320     (unless (zerop length)
321     (funcall output-fn (subseq string start end))
322     (let ((last-newline (position #\newline string :from-end t
323     :start start :end end)))
324     (setf (slot-value stream 'column)
325     (if last-newline
326     (- end last-newline 1)
327     (let ((column (slot-value stream 'column)))
328     (declare (type kernel:index column))
329     (+ column (- end start))))))))
330     string)
331    
332     ;;;
333    
334     (defimplementation make-fn-streams (input-fn output-fn)
335     (let* ((output (make-slime-output-stream output-fn))
336     (input (make-slime-input-stream input-fn output)))
337     (values input output)))
338    
339     (defimplementation make-stream-interactive (stream)
340     (when (or (typep stream 'slime-input-stream)
341     (typep stream 'slime-output-stream))
342     (setf (slot-value stream 'interactive) t)))
343    
344    
345     ;;;; Compilation Commands
346    
347     (defvar *previous-compiler-condition* nil
348     "Used to detect duplicates.")
349    
350     (defvar *previous-context* nil
351     "Previous compiler error context.")
352    
353     (defvar *buffer-name* nil
354     "The name of the Emacs buffer we are compiling from.
355     Nil if we aren't compiling from a buffer.")
356    
357     (defvar *buffer-start-position* nil)
358     (defvar *buffer-substring* nil)
359    
360     (defimplementation call-with-compilation-hooks (function)
361     (let ((*previous-compiler-condition* nil)
362     (*previous-context* nil)
363     (*print-readably* nil))
364     (handler-bind ((c::compiler-error #'handle-notification-condition)
365     (c::style-warning #'handle-notification-condition)
366     (c::warning #'handle-notification-condition))
367     (funcall function))))
368    
369     (defimplementation swank-compile-file (filename load-p
370     &optional external-format)
371     (let ((external-format (if external-format
372     (find-external-format external-format)
373     :default)))
374     (with-compilation-hooks ()
375     (let ((*buffer-name* nil)
376     (ext:*ignore-extra-close-parentheses* nil))
377     (multiple-value-bind (output-file warnings-p failure-p)
378     (compile-file filename :external-format external-format)
379     (unless failure-p
380     ;; Cache the latest source file for definition-finding.
381     (source-cache-get filename (file-write-date filename))
382     (when load-p (load output-file)))
383     (values output-file warnings-p failure-p))))))
384    
385     (defimplementation swank-compile-string (string &key buffer position directory)
386     (declare (ignore directory))
387     (with-compilation-hooks ()
388     (let ((*buffer-name* buffer)
389     (*buffer-start-position* position)
390     (*buffer-substring* string))
391     (with-input-from-string (stream string)
392     (ext:compile-from-stream
393     stream
394     :source-info `(:emacs-buffer ,buffer
395     :emacs-buffer-offset ,position
396     :emacs-buffer-string ,string))))))
397    
398    
399     ;;;;; Trapping notes
400     ;;;
401     ;;; We intercept conditions from the compiler and resignal them as
402     ;;; `swank:compiler-condition's.
403    
404     (defun handle-notification-condition (condition)
405     "Handle a condition caused by a compiler warning."
406     (unless (eq condition *previous-compiler-condition*)
407     (let ((context (c::find-error-context nil)))
408     (setq *previous-compiler-condition* condition)
409     (setq *previous-context* context)
410     (signal-compiler-condition condition context))))
411    
412     (defun signal-compiler-condition (condition context)
413     (signal (make-condition
414     'compiler-condition
415     :original-condition condition
416     :severity (severity-for-emacs condition)
417     :short-message (brief-compiler-message-for-emacs condition)
418     :message (long-compiler-message-for-emacs condition context)
419     :location (if (read-error-p condition)
420     (read-error-location condition)
421     (compiler-note-location context)))))
422    
423     (defun severity-for-emacs (condition)
424     "Return the severity of 'condition."
425     (etypecase condition
426     ((satisfies read-error-p) :read-error)
427     (c::compiler-error :error)
428     (c::style-warning :note)
429     (c::warning :warning)))
430    
431     (defun read-error-p (condition)
432     (eq (type-of condition) 'c::compiler-read-error))
433    
434     (defun brief-compiler-message-for-emacs (condition)
435     "Briefly describe a compiler error for Emacs.
436     When Emacs presents the message it already has the source popped up
437     and the source form highlighted. This makes much of the information in
438     the error-context redundant."
439     (princ-to-string condition))
440    
441     (defun long-compiler-message-for-emacs (condition error-context)
442     "Describe a compiler error for Emacs including context information."
443     (declare (type (or c::compiler-error-context null) error-context))
444     (multiple-value-bind (enclosing source)
445     (if error-context
446     (values (c::compiler-error-context-enclosing-source error-context)
447     (c::compiler-error-context-source error-context)))
448     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
449     enclosing source condition)))
450    
451     (defun read-error-location (condition)
452     (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
453     (file (c::file-info-name finfo))
454     (pos (c::compiler-read-error-position condition)))
455     (cond ((and (eq file :stream) *buffer-name*)
456     (make-location (list :buffer *buffer-name*)
457     (list :position (+ *buffer-start-position* pos))))
458     ((and (pathnamep file) (not *buffer-name*))
459     (make-location (list :file (unix-truename file))
460     (list :position (1+ pos))))
461     (t (break)))))
462    
463     (defun compiler-note-location (context)
464     "Derive the location of a complier message from its context.
465     Return a `location' record, or (:error <reason>) on failure."
466     (if (null context)
467     (note-error-location)
468     (let ((file (c::compiler-error-context-file-name context))
469     (source (c::compiler-error-context-original-source context))
470     (path
471     (reverse (c::compiler-error-context-original-source-path context))))
472     (or (locate-compiler-note file source path)
473     (note-error-location)))))
474    
475     (defun note-error-location ()
476     "Pseudo-location for notes that can't be located."
477     (list :error "No error location available."))
478    
479     (defun locate-compiler-note (file source source-path)
480     (cond ((and (eq file :stream) *buffer-name*)
481     ;; Compiling from a buffer
482     (let ((position (+ *buffer-start-position*
483     (source-path-string-position
484     source-path *buffer-substring*))))
485     (make-location (list :buffer *buffer-name*)
486     (list :position position))))
487     ((and (pathnamep file) (null *buffer-name*))
488     ;; Compiling from a file
489     (make-location (list :file (unix-truename file))
490     (list :position
491     (1+ (source-path-file-position
492     source-path file)))))
493     ((and (eq file :lisp) (stringp source))
494     ;; No location known, but we have the source form.
495     ;; XXX How is this case triggered? -luke (16/May/2004)
496     ;; This can happen if the compiler needs to expand a macro
497     ;; but the macro-expander is not yet compiled. Calling the
498     ;; (interpreted) macro-expander triggers IR1 conversion of
499     ;; the lambda expression for the expander and invokes the
500     ;; compiler recursively.
501     (make-location (list :source-form source)
502     (list :position 1)))))
503    
504     (defun unix-truename (pathname)
505     (ext:unix-namestring (truename pathname)))
506    
507    
508    
509     ;;; TODO
510     (defimplementation who-calls (name) nil)
511     (defimplementation who-references (name) nil)
512     (defimplementation who-binds (name) nil)
513     (defimplementation who-sets (name) nil)
514     (defimplementation who-specializes (symbol) nil)
515     (defimplementation who-macroexpands (name) nil)
516    
517    
518     ;;;; Find callers and callees
519     ;;;
520     ;;; Find callers and callees by looking at the constant pool of
521     ;;; compiled code objects. We assume every fdefn object in the
522     ;;; constant pool corresponds to a call to that function. A better
523     ;;; strategy would be to use the disassembler to find actual
524     ;;; call-sites.
525    
526     (declaim (inline map-code-constants))
527     (defun map-code-constants (code fn)
528     "Call 'fn for each constant in 'code's constant pool."
529     (check-type code kernel:code-component)
530     (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
531     do (funcall fn (kernel:code-header-ref code i))))
532    
533     (defun function-callees (function)
534     "Return 'function's callees as a list of functions."
535     (let ((callees '()))
536     (map-code-constants
537     (vm::find-code-object function)
538     (lambda (obj)
539     (when (kernel:fdefn-p obj)
540     (push (kernel:fdefn-function obj) callees))))
541     callees))
542    
543     (declaim (ext:maybe-inline map-allocated-code-components))
544     (defun map-allocated-code-components (spaces fn)
545     "Call FN for each allocated code component in one of 'spaces. FN
546     receives the object as argument. 'spaces should be a list of the
547     symbols :dynamic, :static, or :read-only."
548     (dolist (space spaces)
549     (declare (inline vm::map-allocated-objects)
550     (optimize (ext:inhibit-warnings 3)))
551     (vm::map-allocated-objects
552     (lambda (obj header size)
553     (declare (type fixnum size) (ignore size))
554     (when (= vm:code-header-type header)
555     (funcall fn obj)))
556     space)))
557    
558     (declaim (ext:maybe-inline map-caller-code-components))
559     (defun map-caller-code-components (function spaces fn)
560     "Call 'fn for each code component with a fdefn for 'function in its
561     constant pool."
562     (let ((function (coerce function 'function)))
563     (declare (inline map-allocated-code-components))
564     (map-allocated-code-components
565     spaces
566     (lambda (obj)
567     (map-code-constants
568     obj
569     (lambda (constant)
570     (when (and (kernel:fdefn-p constant)
571     (eq (kernel:fdefn-function constant)
572     function))
573     (funcall fn obj))))))))
574    
575     (defun function-callers (function &optional (spaces '(:read-only :static
576     :dynamic)))
577     "Return 'function's callers. The result is a list of code-objects."
578     (let ((referrers '()))
579     (declare (inline map-caller-code-components))
580     (map-caller-code-components function spaces
581     (lambda (code) (push code referrers)))
582     referrers))
583    
584     (defun debug-info-definitions (debug-info)
585     "Return the defintions for a debug-info. This should only be used
586     for code-object without entry points, i.e., byte compiled
587     code (are theree others?)"
588     ;; This mess has only been tested with #'ext::skip-whitespace, a
589     ;; byte-compiled caller of #'read-char .
590     (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
591     (let ((name (c::debug-info-name debug-info))
592     (source (c::debug-info-source debug-info)))
593     (destructuring-bind (first) source
594     (ecase (c::debug-source-from first)
595     (:file
596     (list (list name
597     (make-location
598     (list :file (unix-truename (c::debug-source-name first)))
599     (list :function-name (string name))))))))))
600    
601     (defun valid-function-name-p (name)
602     (or (symbolp name) (and (consp name)
603     (eq (car name) 'setf)
604     (symbolp (cadr name))
605     (not (cddr name)))))
606    
607     (defun code-component-entry-points (code)
608     "Return a list ((name location) ...) of function definitons for
609     the code omponent 'code."
610     (let ((names '()))
611     (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
612     ((not f))
613     (let ((name (kernel:%function-name f)))
614     (when (valid-function-name-p name)
615     (push (list name (function-location f)) names))))
616     names))
617    
618     (defimplementation list-callers (symbol)
619     "Return a list ((name location) ...) of callers."
620     (let ((components (function-callers symbol))
621     (xrefs '()))
622     (dolist (code components)
623     (let* ((entry (kernel:%code-entry-points code))
624     (defs (if entry
625     (code-component-entry-points code)
626     ;; byte compiled stuff
627     (debug-info-definitions
628     (kernel:%code-debug-info code)))))
629     (setq xrefs (nconc defs xrefs))))
630     xrefs))
631    
632     (defimplementation list-callees (symbol)
633     (let ((fns (function-callees symbol)))
634     (mapcar (lambda (fn)
635     (list (kernel:%function-name fn)
636     (function-location fn)))
637     fns)))
638    
639    
640     ;;;; Resolving source locations
641     ;;;
642     ;;; Our mission here is to "resolve" references to code locations into
643     ;;; actual file/buffer names and character positions. The references
644     ;;; we work from come out of the compiler's statically-generated debug
645     ;;; information, such as `code-location''s and `debug-source''s. For
646     ;;; more details, see the "Debugger Programmer's Interface" section of
647     ;;; the SCL manual.
648     ;;;
649     ;;; The first step is usually to find the corresponding "source-path"
650     ;;; for the location. Once we have the source-path we can pull up the
651     ;;; source file and `READ' our way through to the right position. The
652     ;;; main source-code groveling work is done in
653     ;;; `swank-source-path-parser.lisp'.
654    
655     (defvar *debug-definition-finding* nil
656     "When true don't handle errors while looking for definitions.
657     This is useful when debugging the definition-finding code.")
658    
659     (defvar *source-snippet-size* 256
660     "Maximum number of characters in a snippet of source code.
661     Snippets at the beginning of definitions are used to tell Emacs what
662     the definitions looks like, so that it can accurately find them by
663     text search.")
664    
665     (defmacro safe-definition-finding (&body body)
666     "Execute 'body and return the source-location it returns.
667     If an error occurs and `*debug-definition-finding*' is false, then
668     return an error pseudo-location.
669    
670     The second return value is 'nil if no error occurs, otherwise it is the
671     condition object."
672     `(flet ((body () ,@body))
673     (if *debug-definition-finding*
674     (body)
675     (handler-case (values (progn ,@body) nil)
676     (error (c) (values (list :error (princ-to-string c)) c))))))
677    
678     (defun code-location-source-location (code-location)
679     "Safe wrapper around `code-location-from-source-location'."
680     (safe-definition-finding
681     (source-location-from-code-location code-location)))
682    
683     (defun source-location-from-code-location (code-location)
684     "Return the source location for 'code-location."
685     (let ((debug-fun (di:code-location-debug-function code-location)))
686     (when (di::bogus-debug-function-p debug-fun)
687     ;; Those lousy cheapskates! They've put in a bogus debug source
688     ;; because the code was compiled at a low debug setting.
689     (error "Bogus debug function: ~A" debug-fun)))
690     (let* ((debug-source (di:code-location-debug-source code-location))
691     (from (di:debug-source-from debug-source))
692     (name (di:debug-source-name debug-source)))
693     (ecase from
694     (:file
695     (location-in-file name code-location debug-source))
696     (:stream
697     (location-in-stream code-location debug-source))
698     (:lisp
699     ;; The location comes from a form passed to `compile'.
700     ;; The best we can do is return the form itself for printing.
701     (make-location
702     (list :source-form (with-output-to-string (*standard-output*)
703     (debug::print-code-location-source-form
704     code-location 100 t)))
705     (list :position 1))))))
706    
707     (defun location-in-file (filename code-location debug-source)
708     "Resolve the source location for 'code-location in 'filename."
709     (let* ((code-date (di:debug-source-created debug-source))
710     (source-code (get-source-code filename code-date)))
711     (with-input-from-string (s source-code)
712     (make-location (list :file (unix-truename filename))
713     (list :position (1+ (code-location-stream-position
714     code-location s)))
715     `(:snippet ,(read-snippet s))))))
716    
717     (defun location-in-stream (code-location debug-source)
718     "Resolve the source location for a 'code-location from a stream.
719     This only succeeds if the code was compiled from an Emacs buffer."
720     (unless (debug-source-info-from-emacs-buffer-p debug-source)
721     (error "The code is compiled from a non-SLIME stream."))
722     (let* ((info (c::debug-source-info debug-source))
723     (string (getf info :emacs-buffer-string))
724     (position (code-location-string-offset
725     code-location
726     string)))
727     (make-location
728     (list :buffer (getf info :emacs-buffer))
729     (list :position (+ (getf info :emacs-buffer-offset) position))
730     (list :snippet (with-input-from-string (s string)
731     (file-position s position)
732     (read-snippet s))))))
733    
734     ;;;;; Function-name locations
735     ;;;
736     (defun debug-info-function-name-location (debug-info)
737     "Return a function-name source-location for 'debug-info.
738     Function-name source-locations are a fallback for when precise
739     positions aren't available."
740     (with-struct (c::debug-info- (fname name) source) debug-info
741     (with-struct (c::debug-source- info from name) (car source)
742     (ecase from
743     (:file
744     (make-location (list :file (namestring (truename name)))
745     (list :function-name (string fname))))
746     (:stream
747     (assert (debug-source-info-from-emacs-buffer-p (car source)))
748     (make-location (list :buffer (getf info :emacs-buffer))
749     (list :function-name (string fname))))
750     (:lisp
751     (make-location (list :source-form (princ-to-string (aref name 0)))
752     (list :position 1)))))))
753    
754     (defun debug-source-info-from-emacs-buffer-p (debug-source)
755     "Does the `info' slot of 'debug-source contain an Emacs buffer location?
756     This is true for functions that were compiled directly from buffers."
757     (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
758    
759     (defun info-from-emacs-buffer-p (info)
760     (and info
761     (consp info)
762     (eq :emacs-buffer (car info))))
763    
764    
765     ;;;;; Groveling source-code for positions
766    
767     (defun code-location-stream-position (code-location stream)
768     "Return the byte offset of 'code-location in 'stream. Extract the
769     toplevel-form-number and form-number from 'code-location and use that
770     to find the position of the corresponding form.
771    
772     Finish with 'stream positioned at the start of the code location."
773     (let* ((location (debug::maybe-block-start-location code-location))
774     (tlf-offset (di:code-location-top-level-form-offset location))
775     (form-number (di:code-location-form-number location)))
776     (let ((pos (form-number-stream-position tlf-offset form-number stream)))
777     (file-position stream pos)
778     pos)))
779    
780     (defun form-number-stream-position (tlf-number form-number stream)
781     "Return the starting character position of a form in 'stream.
782     'tlf-number is the top-level-form number.
783     'form-number is an index into a source-path table for the TLF."
784     (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
785     (let* ((path-table (di:form-number-translations tlf 0))
786     (source-path
787     (if (<= (length path-table) form-number) ; source out of sync?
788     (list 0) ; should probably signal a condition
789     (reverse (cdr (aref path-table form-number))))))
790     (source-path-source-position source-path tlf position-map))))
791    
792     (defun code-location-string-offset (code-location string)
793     "Return the byte offset of 'code-location in 'string.
794     See 'code-location-stream-position."
795     (with-input-from-string (s string)
796     (code-location-stream-position code-location s)))
797    
798    
799     ;;;; Finding definitions
800    
801     ;;; There are a great many different types of definition for us to
802     ;;; find. We search for definitions of every kind and return them in a
803     ;;; list.
804    
805     (defimplementation find-definitions (name)
806     (append (function-definitions name)
807     (setf-definitions name)
808     (variable-definitions name)
809     (class-definitions name)
810     (type-definitions name)
811     (compiler-macro-definitions name)
812     (source-transform-definitions name)
813     (function-info-definitions name)
814     (ir1-translator-definitions name)))
815    
816     ;;;;; Functions, macros, generic functions, methods
817     ;;;
818     ;;; We make extensive use of the compile-time debug information that
819     ;;; SCL records, in particular "debug functions" and "code
820     ;;; locations." Refer to the "Debugger Programmer's Interface" section
821     ;;; of the SCL manual for more details.
822    
823     (defun function-definitions (name)
824     "Return definitions for 'name in the \"function namespace\", i.e.,
825     regular functions, generic functions, methods and macros.
826     'name can any valid function name (e.g, (setf car))."
827     (let ((macro? (and (symbolp name) (macro-function name)))
828     (special? (and (symbolp name) (special-operator-p name)))
829     (function? (and (valid-function-name-p name)
830     (ext:info :function :definition name)
831     (if (symbolp name) (fboundp name) t))))
832     (cond (macro?
833     (list `((defmacro ,name)
834     ,(function-location (macro-function name)))))
835     (special?
836     (list `((:special-operator ,name)
837     (:error ,(format nil "Special operator: ~S" name)))))
838     (function?
839     (let ((function (fdefinition name)))
840     (if (genericp function)
841     (generic-function-definitions name function)
842     (list (list `(function ,name)
843     (function-location function)))))))))
844    
845     ;;;;;; Ordinary (non-generic/macro/special) functions
846     ;;;
847     ;;; First we test if FUNCTION is a closure created by defstruct, and
848     ;;; if so extract the defstruct-description (`dd') from the closure
849     ;;; and find the constructor for the struct. Defstruct creates a
850     ;;; defun for the default constructor and we use that as an
851     ;;; approximation to the source location of the defstruct.
852     ;;;
853     ;;; For an ordinary function we return the source location of the
854     ;;; first code-location we find.
855     ;;;
856     (defun function-location (function)
857     "Return the source location for FUNCTION."
858     (cond ((struct-closure-p function)
859     (struct-closure-location function))
860     ((c::byte-function-or-closure-p function)
861     (byte-function-location function))
862     (t
863     (compiled-function-location function))))
864    
865     (defun compiled-function-location (function)
866     "Return the location of a regular compiled function."
867     (multiple-value-bind (code-location error)
868     (safe-definition-finding (function-first-code-location function))
869     (cond (error (list :error (princ-to-string error)))
870     (t (code-location-source-location code-location)))))
871    
872     (defun function-first-code-location (function)
873     "Return the first code-location we can find for 'function."
874     (and (function-has-debug-function-p function)
875     (di:debug-function-start-location
876     (di:function-debug-function function))))
877    
878     (defun function-has-debug-function-p (function)
879     (di:function-debug-function function))
880    
881     (defun function-code-object= (closure function)
882     (and (eq (vm::find-code-object closure)
883     (vm::find-code-object function))
884     (not (eq closure function))))
885    
886    
887     (defun byte-function-location (fn)
888     "Return the location of the byte-compiled function 'fn."
889     (etypecase fn
890     ((or c::hairy-byte-function c::simple-byte-function)
891     (let* ((component (c::byte-function-component fn))
892     (debug-info (kernel:%code-debug-info component)))
893     (debug-info-function-name-location debug-info)))
894     (c::byte-closure
895     (byte-function-location (c::byte-closure-function fn)))))
896    
897     ;;; Here we deal with structure accessors. Note that `dd' is a
898     ;;; "defstruct descriptor" structure in SCL. A `dd' describes a
899     ;;; `defstruct''d structure.
900    
901     (defun struct-closure-p (function)
902     "Is 'function a closure created by defstruct?"
903     (or (function-code-object= function #'kernel::structure-slot-accessor)
904     (function-code-object= function #'kernel::structure-slot-setter)
905     (function-code-object= function #'kernel::%defstruct)))
906    
907     (defun struct-closure-location (function)
908     "Return the location of the structure that 'function belongs to."
909     (assert (struct-closure-p function))
910     (safe-definition-finding
911     (dd-location (struct-closure-dd function))))
912    
913     (defun struct-closure-dd (function)
914     "Return the defstruct-definition (dd) of FUNCTION."
915     (assert (= (kernel:get-type function) vm:closure-header-type))
916     (flet ((find-layout (function)
917     (sys:find-if-in-closure
918     (lambda (x)
919     (let ((value (if (di::indirect-value-cell-p x)
920     (c:value-cell-ref x)
921     x)))
922     (when (kernel::layout-p value)
923     (return-from find-layout value))))
924     function)))
925     (kernel:layout-info (find-layout function))))
926    
927     (defun dd-location (dd)
928     "Return the location of a `defstruct'."
929     ;; Find the location in a constructor.
930     (function-location (struct-constructor dd)))
931    
932     (defun struct-constructor (dd)
933     "Return a constructor function from a defstruct definition.
934     Signal an error if no constructor can be found."
935     (let ((constructor (or (kernel:dd-default-constructor dd)
936     (car (kernel::dd-constructors dd)))))
937     (when (or (null constructor)
938     (and (consp constructor) (null (car constructor))))
939     (error "Cannot find structure's constructor: ~S"
940     (kernel::dd-name dd)))
941     (coerce (if (consp constructor) (first constructor) constructor)
942     'function)))
943    
944     ;;;;;; Generic functions and methods
945    
946     (defun generic-function-definitions (name function)
947     "Return the definitions of a generic function and its methods."
948     (cons (list `(defgeneric ,name) (gf-location function))
949     (gf-method-definitions function)))
950    
951     (defun gf-location (gf)
952     "Return the location of the generic function GF."
953     (definition-source-location gf (clos:generic-function-name gf)))
954    
955     (defun gf-method-definitions (gf)
956     "Return the locations of all methods of the generic function GF."
957     (mapcar #'method-definition (clos:generic-function-methods gf)))
958    
959     (defun method-definition (method)
960     (list (method-dspec method)
961     (method-location method)))
962    
963     (defun method-dspec (method)
964     "Return a human-readable \"definition specifier\" for METHOD."
965     (let* ((gf (clos:method-generic-function method))
966     (name (clos:generic-function-name gf))
967     (specializers (clos:method-specializers method))
968     (qualifiers (clos:method-qualifiers method)))
969     `(method ,name ,@qualifiers ,specializers #+nil (clos::unparse-specializers specializers))))
970    
971     ;; XXX maybe special case setters/getters
972     (defun method-location (method)
973     (function-location (clos:method-function method)))
974    
975     (defun genericp (fn)
976     (typep fn 'generic-function))
977    
978     ;;;;;; Types and classes
979    
980     (defun type-definitions (name)
981     "Return `deftype' locations for type NAME."
982     (maybe-make-definition (ext:info :type :expander name) 'deftype name))
983    
984     (defun maybe-make-definition (function kind name)
985     "If FUNCTION is non-nil then return its definition location."
986     (if function
987     (list (list `(,kind ,name) (function-location function)))))
988    
989     (defun class-definitions (name)
990     "Return the definition locations for the class called NAME."
991     (if (symbolp name)
992     (let ((class (find-class name nil)))
993     (etypecase class
994     (null '())
995     (structure-class
996     (list (list `(defstruct ,name)
997     (dd-location (find-dd name)))))
998     (standard-class
999     (list (list `(defclass ,name)
1000     (class-location (find-class name)))))
1001     ((or built-in-class
1002     kernel:funcallable-structure-class)
1003     (list (list `(kernel::define-type-class ,name)
1004     `(:error
1005     ,(format nil "No source info for ~A" name)))))))))
1006    
1007     (defun class-location (class)
1008     "Return the `defclass' location for CLASS."
1009     (definition-source-location class (class-name class)))
1010    
1011     (defun find-dd (name)
1012     "Find the defstruct-definition by the name of its structure-class."
1013     (let ((layout (ext:info :type :compiler-layout name)))
1014     (if layout
1015     (kernel:layout-info layout))))
1016    
1017     (defun condition-class-location (class)
1018     (let ((name (class-name class)))
1019     `(:error ,(format nil "No location info for condition: ~A" name))))
1020    
1021     (defun make-name-in-file-location (file string)
1022     (multiple-value-bind (filename c)
1023     (ignore-errors
1024     (unix-truename (merge-pathnames (make-pathname :type "lisp")
1025     file)))
1026     (cond (filename (make-location `(:file ,filename)
1027     `(:function-name ,(string string))))
1028     (t (list :error (princ-to-string c))))))
1029    
1030     (defun definition-source-location (object name)
1031     `(:error ,(format nil "No source info for: ~A" object)))
1032    
1033     (defun setf-definitions (name)
1034     (let ((function (or (ext:info :setf :inverse name)
1035     (ext:info :setf :expander name))))
1036     (if function
1037     (list (list `(setf ,name)
1038     (function-location (coerce function 'function)))))))
1039    
1040    
1041     (defun variable-location (symbol)
1042     `(:error ,(format nil "No source info for variable ~S" symbol)))
1043    
1044     (defun variable-definitions (name)
1045     (if (symbolp name)
1046     (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
1047     (if recorded-p
1048     (list (list `(variable ,kind ,name)
1049     (variable-location name)))))))
1050    
1051     (defun compiler-macro-definitions (symbol)
1052     (maybe-make-definition (compiler-macro-function symbol)
1053     'define-compiler-macro
1054     symbol))
1055    
1056     (defun source-transform-definitions (name)
1057     (maybe-make-definition (ext:info :function :source-transform name)
1058     'c:def-source-transform
1059     name))
1060    
1061     (defun function-info-definitions (name)
1062     (let ((info (ext:info :function :info name)))
1063     (if info
1064     (append (loop for transform in (c::function-info-transforms info)
1065     collect (list `(c:deftransform ,name
1066     ,(c::type-specifier
1067     (c::transform-type transform)))
1068     (function-location (c::transform-function
1069     transform))))
1070     (maybe-make-definition (c::function-info-derive-type info)
1071     'c::derive-type name)
1072     (maybe-make-definition (c::function-info-optimizer info)
1073     'c::optimizer name)
1074     (maybe-make-definition (c::function-info-ltn-annotate info)
1075     'c::ltn-annotate name)
1076     (maybe-make-definition (c::function-info-ir2-convert info)
1077     'c::ir2-convert name)
1078     (loop for template in (c::function-info-templates info)
1079     collect (list `(c::vop ,(c::template-name template))
1080     (function-location
1081     (c::vop-info-generator-function
1082     template))))))))
1083    
1084     (defun ir1-translator-definitions (name)
1085     (maybe-make-definition (ext:info :function :ir1-convert name)
1086     'c:def-ir1-translator name))
1087    
1088    
1089     ;;;; Documentation.
1090    
1091     (defimplementation describe-symbol-for-emacs (symbol)
1092     (let ((result '()))
1093     (flet ((doc (kind)
1094     (or (documentation symbol kind) :not-documented))
1095     (maybe-push (property value)
1096     (when value
1097     (setf result (list* property value result)))))
1098     (maybe-push
1099     :variable (multiple-value-bind (kind recorded-p)
1100     (ext:info variable kind symbol)
1101     (declare (ignore kind))
1102     (if (or (boundp symbol) recorded-p)
1103     (doc 'variable))))
1104     (when (fboundp symbol)
1105     (maybe-push
1106     (cond ((macro-function symbol) :macro)
1107     ((special-operator-p symbol) :special-operator)
1108     ((genericp (fdefinition symbol)) :generic-function)
1109     (t :function))
1110     (doc 'function)))
1111     (maybe-push
1112     :setf (if (or (ext:info setf inverse symbol)
1113     (ext:info setf expander symbol))
1114     (doc 'setf)))
1115     (maybe-push
1116     :type (if (ext:info type kind symbol)
1117     (doc 'type)))
1118     (maybe-push
1119     :class (if (find-class symbol nil)
1120     (doc 'class)))
1121     (maybe-push
1122     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
1123     (doc 'alien-type)))
1124     (maybe-push
1125     :alien-struct (if (ext:info alien-type struct symbol)
1126     (doc nil)))
1127     (maybe-push
1128     :alien-union (if (ext:info alien-type union symbol)
1129     (doc nil)))
1130     (maybe-push
1131     :alien-enum (if (ext:info alien-type enum symbol)
1132     (doc nil)))
1133     result)))
1134    
1135     (defimplementation describe-definition (symbol namespace)
1136     (describe (ecase namespace
1137     (:variable
1138     symbol)
1139     ((:function :generic-function)
1140     (symbol-function symbol))
1141     (:setf
1142     (or (ext:info setf inverse symbol)
1143     (ext:info setf expander symbol)))
1144     (:type
1145     (kernel:values-specifier-type symbol))
1146     (:class
1147     (find-class symbol))
1148     (:alien-struct
1149     (ext:info :alien-type :struct symbol))
1150     (:alien-union
1151     (ext:info :alien-type :union symbol))
1152     (:alien-enum
1153     (ext:info :alien-type :enum symbol))
1154     (:alien-type
1155     (ecase (ext:info :alien-type :kind symbol)
1156     (:primitive
1157     (let ((alien::*values-type-okay* t))
1158     (funcall (ext:info :alien-type :translator symbol)
1159     (list symbol))))
1160     ((:defined)
1161     (ext:info :alien-type :definition symbol))
1162     (:unknown
1163     (return-from describe-definition
1164     (format nil "Unknown alien type: ~S" symbol))))))))
1165    
1166     ;;;;; Argument lists
1167    
1168     (defimplementation arglist ((name symbol))
1169     (cond ((and (symbolp name) (macro-function name))
1170     (arglist (macro-function name)))
1171     ((fboundp name)
1172     (arglist (fdefinition name)))
1173     (t
1174     :not-available)))
1175    
1176     (defimplementation arglist ((fun function))
1177     (flet ((compiled-function-arglist (x)
1178     (let ((args (kernel:%function-arglist x)))
1179     (if args
1180     (read-arglist x)
1181     :not-available))))
1182     (case (kernel:get-type fun)
1183     (#.vm:closure-header-type
1184     (compiled-function-arglist
1185     (kernel:%closure-function fun)))
1186     ((#.vm:function-header-type #.vm:closure-function-header-type)
1187     (compiled-function-arglist fun))
1188     (#.vm:funcallable-instance-header-type
1189     (typecase fun
1190     (kernel:byte-function
1191     :not-available)
1192     (kernel:byte-closure
1193     :not-available)
1194     (eval:interpreted-function
1195     (eval:interpreted-function-arglist fun))
1196     (otherwise
1197     (clos::generic-function-lambda-list fun))))
1198     (t
1199     :non-available))))
1200    
1201     (defimplementation function-name (function)
1202     (cond ((eval:interpreted-function-p function)
1203     (eval:interpreted-function-name function))
1204     ((typep function 'generic-function)
1205     (clos:generic-function-name function))
1206     ((c::byte-function-or-closure-p function)
1207     (c::byte-function-name function))
1208     (t (kernel:%function-name (kernel:%function-self function)))))
1209    
1210     ;;; A simple case: the arglist is available as a string that we can
1211     ;;; `read'.
1212    
1213     (defun read-arglist (fn)
1214     "Parse the arglist-string of the function object FN."
1215     (let ((string (kernel:%function-arglist
1216     (kernel:%function-self fn)))
1217     (package (find-package
1218     (c::compiled-debug-info-package
1219     (kernel:%code-debug-info
1220     (vm::find-code-object fn))))))
1221     (with-standard-io-syntax
1222     (let ((*package* (or package *package*)))
1223     (read-from-string string)))))
1224    
1225     ;;; A harder case: an approximate arglist is derived from available
1226     ;;; debugging information.
1227    
1228     (defun debug-function-arglist (debug-function)
1229     "Derive the argument list of DEBUG-FUNCTION from debug info."
1230     (let ((args (di::debug-function-lambda-list debug-function))
1231     (required '())
1232     (optional '())
1233     (rest '())
1234     (key '()))
1235     ;; collect the names of debug-vars
1236     (dolist (arg args)
1237     (etypecase arg
1238     (di::debug-variable
1239     (push (di::debug-variable-symbol arg) required))
1240     ((member :deleted)
1241     (push ':deleted required))
1242     (cons
1243     (ecase (car arg)
1244     (:keyword
1245     (push (second arg) key))
1246     (:optional
1247     (push (debug-variable-symbol-or-deleted (second arg)) optional))
1248     (:rest
1249     (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
1250     ;; intersperse lambda keywords as needed
1251     (append (nreverse required)
1252     (if optional (cons '&optional (nreverse optional)))
1253     (if rest (cons '&rest (nreverse rest)))
1254     (if key (cons '&key (nreverse key))))))
1255    
1256     (defun debug-variable-symbol-or-deleted (var)
1257     (etypecase var
1258     (di:debug-variable
1259     (di::debug-variable-symbol var))
1260     ((member :deleted)
1261     '#:deleted)))
1262    
1263     (defun symbol-debug-function-arglist (fname)
1264     "Return FNAME's debug-function-arglist and %function-arglist.
1265     A utility for debugging DEBUG-FUNCTION-ARGLIST."
1266     (let ((fn (fdefinition fname)))
1267     (values (debug-function-arglist (di::function-debug-function fn))
1268     (kernel:%function-arglist (kernel:%function-self fn)))))
1269    
1270     ;;; Deriving arglists for byte-compiled functions:
1271     ;;;
1272     (defun byte-code-function-arglist (fn)
1273     ;; There doesn't seem to be much arglist information around for
1274     ;; byte-code functions. Use the arg-count and return something like
1275     ;; (arg0 arg1 ...)
1276     (etypecase fn
1277     (c::simple-byte-function
1278     (loop for i from 0 below (c::simple-byte-function-num-args fn)
1279     collect (make-arg-symbol i)))
1280     (c::hairy-byte-function
1281     (hairy-byte-function-arglist fn))
1282     (c::byte-closure
1283     (byte-code-function-arglist (c::byte-closure-function fn)))))
1284    
1285     (defun make-arg-symbol (i)
1286     (make-symbol (format nil "~A~D" (string 'arg) i)))
1287    
1288     ;;; A "hairy" byte-function is one that takes a variable number of
1289     ;;; arguments. `hairy-byte-function' is a type from the bytecode
1290     ;;; interpreter.
1291     ;;;
1292     (defun hairy-byte-function-arglist (fn)
1293     (let ((counter -1))
1294     (flet ((next-arg () (make-arg-symbol (incf counter))))
1295     (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
1296     keywords-p keywords) fn
1297     (let ((arglist '())
1298     (optional (- max-args min-args)))
1299     ;; XXX isn't there a better way to write this?
1300     ;; (Looks fine to me. -luke)
1301     (dotimes (i min-args)
1302     (push (next-arg) arglist))
1303     (when (plusp optional)
1304     (push '&optional arglist)
1305     (dotimes (i optional)
1306     (push (next-arg) arglist)))
1307     (when rest-arg-p
1308     (push '&rest arglist)
1309     (push (next-arg) arglist))
1310     (when keywords-p
1311     (push '&key arglist)
1312     (loop for (key _ __) in keywords
1313     do (push key arglist))
1314     (when (eq keywords-p :allow-others)
1315     (push '&allow-other-keys arglist)))
1316     (nreverse arglist))))))
1317    
1318    
1319     ;;;; Miscellaneous.
1320    
1321     (defimplementation macroexpand-all (form)
1322     (macroexpand form))
1323    
1324     (defimplementation set-default-directory (directory)
1325     (setf (ext:default-directory) (namestring directory))
1326     ;; Setting *default-pathname-defaults* to an absolute directory
1327     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
1328     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
1329     (default-directory))
1330    
1331     (defimplementation default-directory ()
1332     (namestring (ext:default-directory)))
1333    
1334     (defimplementation call-without-interrupts (fn)
1335     (funcall fn))
1336    
1337     (defimplementation getpid ()
1338     (unix:unix-getpid))
1339    
1340     (defimplementation lisp-implementation-type-name ()
1341     (if (eq ext:*case-mode* :upper) "scl" "scl-lower"))
1342    
1343     (defimplementation quit-lisp ()
1344     (ext:quit))
1345    
1346     ;;; source-path-{stream,file,string,etc}-position moved into
1347     ;;; swank-source-path-parser
1348    
1349    
1350     ;;;; Debugging
1351    
1352     (defvar *sldb-stack-top*)
1353    
1354     (defimplementation call-with-debugging-environment (debugger-loop-fn)
1355     (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
1356     (debug:*stack-top-hint* nil)
1357     (kernel:*current-level* 0))
1358     (handler-bind ((di::unhandled-condition
1359     (lambda (condition)
1360     (error (make-condition
1361     'sldb-condition
1362     :original-condition condition)))))
1363     (funcall debugger-loop-fn))))
1364    
1365     (defun frame-down (frame)
1366     (handler-case (di:frame-down frame)
1367     (di:no-debug-info () nil)))
1368    
1369     (defun nth-frame (index)
1370     (do ((frame *sldb-stack-top* (frame-down frame))
1371     (i index (1- i)))
1372     ((zerop i) frame)))
1373    
1374     (defimplementation compute-backtrace (start end)
1375     (let ((end (or end most-positive-fixnum)))
1376     (loop for f = (nth-frame start) then (frame-down f)
1377     for i from start below end
1378     while f
1379     collect f)))
1380    
1381     (defimplementation print-frame (frame stream)
1382     (let ((*standard-output* stream))
1383     (handler-case
1384     (debug::print-frame-call frame :verbosity 1 :number nil)
1385     (error (e)
1386     (ignore-errors (princ e stream))))))
1387    
1388     (defimplementation frame-source-location-for-emacs (index)
1389     (code-location-source-location (di:frame-code-location (nth-frame index))))
1390    
1391     (defimplementation eval-in-frame (form index)
1392     (di:eval-in-frame (nth-frame index) form))
1393    
1394     (defun frame-debug-vars (frame)
1395     "Return a vector of debug-variables in frame."
1396     (di::debug-function-debug-variables (di:frame-debug-function frame)))
1397    
1398     (defun debug-var-value (var frame location)
1399     (let ((validity (di:debug-variable-validity var location)))
1400     (ecase validity
1401     (:valid (di:debug-variable-value var frame))
1402     ((:invalid :unknown) (make-symbol (string validity))))))
1403    
1404     (defimplementation frame-locals (index)
1405     (let* ((frame (nth-frame index))
1406     (loc (di:frame-code-location frame))
1407     (vars (frame-debug-vars frame)))
1408     (loop for v across vars collect
1409     (list :name (di:debug-variable-symbol v)
1410     :id (di:debug-variable-id v)
1411     :value (debug-var-value v frame loc)))))
1412    
1413     (defimplementation frame-var-value (frame var)
1414     (let* ((frame (nth-frame frame))
1415     (dvar (aref (frame-debug-vars frame) var)))
1416     (debug-var-value dvar frame (di:frame-code-location frame))))
1417    
1418     (defimplementation frame-catch-tags (index)
1419     (mapcar #'car (di:frame-catches (nth-frame index))))
1420    
1421     (defimplementation return-from-frame (index form)
1422     (let ((sym (find-symbol (string 'find-debug-tag-for-frame)
1423     :debug-internals)))
1424     (if sym
1425     (let* ((frame (nth-frame index))
1426     (probe (funcall sym frame)))
1427     (cond (probe (throw (car probe) (eval-in-frame form index)))
1428     (t (format nil "Cannot return from frame: ~S" frame))))
1429     "return-from-frame is not implemented in this version of SCL.")))
1430    
1431     (defimplementation activate-stepping (frame)
1432     (set-step-breakpoints (nth-frame frame)))
1433    
1434     (defimplementation sldb-break-on-return (frame)
1435     (break-on-return (nth-frame frame)))
1436    
1437     ;;; We set the breakpoint in the caller which might be a bit confusing.
1438     ;;;
1439     (defun break-on-return (frame)
1440     (let* ((caller (di:frame-down frame))
1441     (cl (di:frame-code-location caller)))
1442     (flet ((hook (frame bp)
1443     (when (frame-pointer= frame caller)
1444     (di:delete-breakpoint bp)
1445     (signal-breakpoint bp frame))))
1446     (let* ((info (ecase (di:code-location-kind cl)
1447     ((:single-value-return :unknown-return) nil)
1448     (:known-return (debug-function-returns
1449     (di:frame-debug-function frame)))))
1450     (bp (di:make-breakpoint #'hook cl :kind :code-location
1451     :info info)))
1452     (di:activate-breakpoint bp)
1453     `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
1454    
1455     (defun frame-pointer= (frame1 frame2)
1456     "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
1457     (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
1458    
1459     ;;; The PC in escaped frames at a single-return-value point is
1460     ;;; actually vm:single-value-return-byte-offset bytes after the
1461     ;;; position given in the debug info. Here we try to recognize such
1462     ;;; cases.
1463     ;;;
1464     (defun next-code-locations (frame code-location)
1465     "Like `debug::next-code-locations' but be careful in escaped frames."
1466     (let ((next (debug::next-code-locations code-location)))
1467     (flet ((adjust-pc ()
1468     (let ((cl (di::copy-compiled-code-location code-location)))
1469     (incf (di::compiled-code-location-pc cl)
1470     vm:single-value-return-byte-offset)
1471     cl)))
1472     (cond ((and (di::compiled-frame-escaped frame)
1473     (eq (di:code-location-kind code-location)
1474     :single-value-return)
1475     (= (length next) 1)
1476     (di:code-location= (car next) (adjust-pc)))
1477     (debug::next-code-locations (car next)))
1478     (t
1479     next)))))
1480    
1481     (defun set-step-breakpoints (frame)
1482     (let ((cl (di:frame-code-location frame)))
1483     (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
1484     (error "Cannot step in elsewhere code"))
1485     (let* ((debug::*bad-code-location-types*
1486     (remove :call-site debug::*bad-code-location-types*))
1487     (next (next-code-locations frame cl)))
1488     (cond (next
1489     (let ((steppoints '()))
1490     (flet ((hook (bp-frame bp)
1491     (signal-breakpoint bp bp-frame)
1492     (mapc #'di:delete-breakpoint steppoints)))
1493     (dolist (code-location next)
1494     (let ((bp (di:make-breakpoint #'hook code-location
1495     :kind :code-location)))
1496     (di:activate-breakpoint bp)
1497     (push bp steppoints))))))
1498     (t
1499     (break-on-return frame))))))
1500    
1501    
1502     ;; XXX the return values at return breakpoints should be passed to the
1503     ;; user hooks. debug-int.lisp should be changed to do this cleanly.
1504    
1505     ;;; The sigcontext and the PC for a breakpoint invocation are not
1506     ;;; passed to user hook functions, but we need them to extract return
1507     ;;; values. So we advice di::handle-breakpoint and bind the values to
1508     ;;; special variables.
1509     ;;;
1510     (defvar *breakpoint-sigcontext*)
1511     (defvar *breakpoint-pc*)
1512    
1513     (defun sigcontext-object (sc index)
1514     "Extract the lisp object in sigcontext SC at offset INDEX."
1515     (kernel:make-lisp-obj (vm:ucontext-register sc index)))
1516    
1517     (defun known-return-point-values (sigcontext sc-offsets)
1518     (let ((fp (system:int-sap (vm:ucontext-register sigcontext
1519     vm::cfp-offset))))
1520     (system:without-gcing
1521     (loop for sc-offset across sc-offsets
1522     collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
1523    
1524     ;;; SCL returns the first few values in registers and the rest on
1525     ;;; the stack. In the multiple value case, the number of values is
1526     ;;; stored in a dedicated register. The values of the registers can be
1527     ;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
1528     ;;; of return conventions: :single-value-return, :unknown-return, and
1529     ;;; :known-return.
1530     ;;;
1531     ;;; The :single-value-return convention returns the value in a
1532     ;;; register without setting the nargs registers.
1533     ;;;
1534     ;;; The :unknown-return variant is used for multiple values. A
1535     ;;; :unknown-return point consists actually of 2 breakpoints: one for
1536     ;;; the single value case and one for the general case. The single
1537     ;;; value breakpoint comes vm:single-value-return-byte-offset after
1538     ;;; the multiple value breakpoint.
1539     ;;;
1540     ;;; The :known-return convention is used by local functions.
1541     ;;; :known-return is currently not supported because we don't know
1542     ;;; where the values are passed.
1543     ;;;
1544     (defun breakpoint-values (breakpoint)
1545     "Return the list of return values for a return point."
1546     (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
1547     (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
1548     (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext))))
1549     (cl (di:breakpoint-what breakpoint)))
1550     (ecase (di:code-location-kind cl)
1551     (:single-value-return
1552     (list (1st sc)))
1553     (:known-return
1554     (let ((info (di:breakpoint-info breakpoint)))
1555     (if (vectorp info)
1556     (known-return-point-values sc info)
1557     (progn
1558     ;;(break)
1559     (list "<<known-return convention not supported>>" info)))))
1560     (:unknown-return
1561     (let ((mv-return-pc (di::compiled-code-location-pc cl)))
1562     (if (= mv-return-pc *breakpoint-pc*)
1563     (mv-function-end-breakpoint-values sc)
1564     (list (1st sc)))))))))
1565    
1566     (defun mv-function-end-breakpoint-values (sigcontext)
1567     (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
1568     (cond (sym (funcall sym sigcontext))
1569     (t (di::get-function-end-breakpoint-values sigcontext)))))
1570    
1571     (defun debug-function-returns (debug-fun)
1572     "Return the return style of DEBUG-FUN."
1573     (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
1574     (c::compiled-debug-function-returns cdfun)))
1575    
1576     (define-condition breakpoint (simple-condition)
1577     ((message :initarg :message :reader breakpoint.message)
1578     (values :initarg :values :reader breakpoint.values))
1579     (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
1580    
1581     (defimplementation condition-extras ((c breakpoint))
1582     ;; simply pop up the source buffer
1583     `((:short-frame-source 0)))
1584    
1585     (defun signal-breakpoint (breakpoint frame)
1586     "Signal a breakpoint condition for BREAKPOINT in FRAME.
1587     Try to create a informative message."
1588     (flet ((brk (values fstring &rest args)
1589     (let ((msg (apply #'format nil fstring args))
1590     (debug:*stack-top-hint* frame))
1591     (break 'breakpoint :message msg :values values))))
1592     (with-struct (di::breakpoint- kind what) breakpoint
1593     (case kind
1594     (:code-location
1595     (case (di:code-location-kind what)
1596     ((:single-value-return :known-return :unknown-return)
1597     (let ((values (breakpoint-values breakpoint)))
1598     (brk values "Return value: ~{~S ~}" values)))
1599     (t
1600     #+(or)
1601     (when (eq (di:code-location-kind what) :call-site)
1602     (call-site-function breakpoint frame))
1603     (brk nil "Breakpoint: ~S ~S"
1604     (di:code-location-kind what)
1605     (di::compiled-code-location-pc what)))))
1606     (:function-start
1607     (brk nil "Function start breakpoint"))
1608     (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
1609    
1610     #+nil
1611     (defimplementation sldb-break-at-start (fname)
1612     (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
1613     (cond ((not debug-fun)
1614     `(:error ,(format nil "~S has no debug-function" fname)))
1615     (t
1616     (flet ((hook (frame bp &optional args cookie)
1617     (declare (ignore args cookie))
1618     (signal-breakpoint bp frame)))
1619     (let ((bp (di:make-breakpoint #'hook debug-fun
1620     :kind :function-start)))
1621     (di:activate-breakpoint bp)
1622     `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
1623    
1624     (defun frame-cfp (frame)
1625     "Return the Control-Stack-Frame-Pointer for FRAME."
1626     (etypecase frame
1627     (di::compiled-frame (di::frame-pointer frame))
1628     ((or di::interpreted-frame null) -1)))
1629    
1630     (defun frame-ip (frame)
1631     "Return the (absolute) instruction pointer and the relative pc of FRAME."
1632     (if (not frame)
1633     -1
1634     (let ((debug-fun (di::frame-debug-function frame)))
1635     (etypecase debug-fun
1636     (di::compiled-debug-function
1637     (let* ((code-loc (di:frame-code-location frame))
1638     (component (di::compiled-debug-function-component debug-fun))
1639     (pc (di::compiled-code-location-pc code-loc))
1640     (ip (sys:without-gcing
1641     (sys:sap-int
1642     (sys:sap+ (kernel:code-instructions component) pc)))))
1643     (values ip pc)))
1644     ((or di::bogus-debug-function di::interpreted-debug-function)
1645     -1)))))
1646    
1647     (defun frame-registers (frame)
1648     "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1649     (let* ((cfp (frame-cfp frame))
1650     (csp (frame-cfp (di::frame-up frame)))
1651     (ip (frame-ip frame))
1652     (ocfp (frame-cfp (di::frame-down frame)))
1653     (lra (frame-ip (di::frame-down frame))))
1654     (values csp cfp ip ocfp lra)))
1655    
1656     (defun print-frame-registers (frame-number)
1657     (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1658     (flet ((fixnum (p) (etypecase p
1659     (integer p)
1660     (sys:system-area-pointer (sys:sap-int p)))))
1661     (apply #'format t "~
1662     CSP = ~X
1663     CFP = ~X
1664     IP = ~X
1665     OCFP = ~X
1666     LRA = ~X~%" (mapcar #'fixnum
1667     (multiple-value-list (frame-registers frame)))))))
1668    
1669    
1670     (defimplementation disassemble-frame (frame-number)
1671     "Return a string with the disassembly of frames code."
1672     (print-frame-registers frame-number)
1673     (terpri)
1674     (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1675     (debug-fun (di::frame-debug-function frame)))
1676     (etypecase debug-fun
1677     (di::compiled-debug-function
1678     (let* ((component (di::compiled-debug-function-component debug-fun))
1679     (fun (di:debug-function-function debug-fun)))
1680     (if fun
1681     (disassemble fun)
1682     (disassem:disassemble-code-component component))))
1683     (di::bogus-debug-function
1684     (format t "~%[Disassembling bogus frames not implemented]")))))
1685    
1686    
1687     ;;;; Inspecting
1688    
1689     (defclass scl-inspector (inspector)
1690     ())
1691    
1692     (defimplementation make-default-inspector ()
1693     (make-instance 'scl-inspector))
1694    
1695     (defconstant +lowtag-symbols+
1696     '(vm:even-fixnum-type
1697     vm:instance-pointer-type
1698     vm:other-immediate-0-type
1699     vm:list-pointer-type
1700     vm:odd-fixnum-type
1701     vm:function-pointer-type
1702     vm:other-immediate-1-type
1703     vm:other-pointer-type)
1704     "Names of the constants that specify type tags.
1705     The `symbol-value' of each element is a type tag.")
1706    
1707     (defconstant +header-type-symbols+
1708     (labels ((suffixp (suffix string)
1709     (and (>= (length string) (length suffix))
1710     (string= string suffix :start1 (- (length string)
1711     (length suffix)))))
1712     (header-type-symbol-p (x)
1713     (and (suffixp (symbol-name '#:-type) (symbol-name x))
1714     (not (member x +lowtag-symbols+))
1715     (boundp x)
1716     (typep (symbol-value x) 'fixnum))))
1717     (remove-if-not #'header-type-symbol-p
1718     (append (apropos-list (symbol-name '#:-type) :vm)
1719     (apropos-list (symbol-name '#:-type) :bignum))))
1720     "A list of names of the type codes in boxed objects.")
1721    
1722     (defimplementation describe-primitive-type (object)
1723     (with-output-to-string (*standard-output*)
1724     (let* ((lowtag (kernel:get-lowtag object))
1725     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1726     (format t "lowtag: ~A" lowtag-symbol)
1727     (when (member lowtag (list vm:other-pointer-type
1728     vm:function-pointer-type
1729     vm:other-immediate-0-type
1730     vm:other-immediate-1-type
1731     ))
1732     (let* ((type (kernel:get-type object))
1733     (type-symbol (find type +header-type-symbols+
1734     :key #'symbol-value)))
1735     (format t ", type: ~A" type-symbol))))))
1736    
1737     (defimplementation inspect-for-emacs ((o t) (inspector scl-inspector))
1738     (cond ((di::indirect-value-cell-p o)
1739     (values (format nil "~A is a value cell." o)
1740     `("Value: " (:value ,(c:value-cell-ref o)))))
1741     ((alien::alien-value-p o)
1742     (inspect-alien-value o))
1743     (t
1744     (scl-inspect o))))
1745    
1746     (defun scl-inspect (o)
1747     (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
1748     (values (format nil "~A~%" text)
1749     (if labeledp
1750     (loop for (label . value) in parts
1751     append (label-value-line label value))
1752     (loop for value in parts for i from 0
1753     append (label-value-line i value))))))
1754    
1755     (defmethod inspect-for-emacs :around ((o function) (inspector scl-inspector))
1756     (declare (ignore inspector))
1757     (let ((header (kernel:get-type o)))
1758     (cond ((= header vm:function-header-type)
1759     (values (format nil "~A is a function." o)
1760     (append (label-value-line*
1761     ("Self" (kernel:%function-self o))
1762     ("Next" (kernel:%function-next o))
1763     ("Name" (kernel:%function-name o))
1764     ("Arglist" (kernel:%function-arglist o))
1765     ("Type" (kernel:%function-type o))
1766     ("Code" (kernel:function-code-header o)))
1767     (list
1768     (with-output-to-string (s)
1769     (disassem:disassemble-function o :stream s))))))
1770     ((= header vm:closure-header-type)
1771     (values (format nil "~A is a closure" o)
1772     (append
1773     (label-value-line "Function" (kernel:%closure-function o))
1774     `("Environment:" (:newline))
1775     (loop for i from 0 below (1- (kernel:get-closure-length o))
1776     append (label-value-line
1777     i (kernel:%closure-index-ref o i))))))
1778     ((eval::interpreted-function-p o)
1779     (scl-inspect o))
1780     (t
1781     (call-next-method)))))
1782    
1783    
1784     (defmethod inspect-for-emacs ((o kernel:code-component) (_ scl-inspector))
1785     (declare (ignore _))
1786     (values (format nil "~A is a code data-block." o)
1787     (append
1788     (label-value-line*
1789     ("code-size" (kernel:%code-code-size o))
1790     ("entry-points" (kernel:%code-entry-points o))
1791     ("debug-info" (kernel:%code-debug-info o))
1792     ("trace-table-offset" (kernel:code-header-ref
1793     o vm:code-trace-table-offset-slot)))
1794     `("Constants:" (:newline))
1795     (loop for i from vm:code-constants-offset
1796     below (kernel:get-header-data o)
1797     append (label-value-line i (kernel:code-header-ref o i)))
1798     `("Code:" (:newline)
1799     , (with-output-to-string (s)
1800     (cond ((kernel:%code-debug-info o)
1801     (disassem:disassemble-code-component o :stream s))
1802     (t
1803     (disassem:disassemble-memory
1804     (disassem::align
1805     (+ (logandc2 (kernel:get-lisp-obj-address o)
1806     vm:lowtag-mask)
1807     (* vm:code-constants-offset vm:word-bytes))
1808     (ash 1 vm:lowtag-bits))
1809     (ash (kernel:%code-code-size o) vm:word-shift)
1810     :stream s))))))))
1811    
1812     (defmethod inspect-for-emacs ((o kernel:fdefn) (inspector scl-inspector))
1813     (declare (ignore inspector))
1814     (values (format nil "~A is a fdenf object." o)
1815     (label-value-line*
1816     ("name" (kernel:fdefn-name o))
1817     ("function" (kernel:fdefn-function o))
1818     ("raw-addr" (sys:sap-ref-32
1819     (sys:int-sap (kernel:get-lisp-obj-address o))
1820     (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
1821    
1822     (defmethod inspect-for-emacs ((o array) (inspector scl-inspector))
1823     inspector
1824     (values (format nil "~A is an array." o)
1825     (label-value-line*
1826     (:header (describe-primitive-type o))
1827     (:rank (array-rank o))
1828     (:fill-pointer (kernel:%array-fill-pointer o))
1829     (:fill-pointer-p (kernel:%array-fill-pointer-p o))
1830     (:elements (kernel:%array-available-elements o))
1831     (:data (kernel:%array-data-vector o))
1832     (:displacement (kernel:%array-displacement o))
1833     (:displaced-p (kernel:%array-displaced-p o))
1834     (:dimensions (array-dimensions o)))))
1835    
1836     (defmethod inspect-for-emacs ((o vector) (inspector scl-inspector))
1837     inspector
1838     (values (format nil "~A is a vector." o)
1839     (append
1840     (label-value-line*
1841     (:header (describe-primitive-type o))
1842     (:length (c::vector-length o)))
1843     (unless (eq (array-element-type o) 'nil)
1844     (loop for i below (length o)
1845     append (label-value-line i (aref o i)))))))
1846    
1847     (defun inspect-alien-record (alien)
1848     (values
1849     (format nil "~A is an alien value." alien)
1850     (with-struct (alien::alien-value- sap type) alien
1851     (with-struct (alien::alien-record-type- kind name fields) type
1852     (append
1853     (label-value-line*
1854     (:sap sap)
1855     (:kind kind)
1856     (:name name))
1857     (loop for field in fields
1858     append (let ((slot (alien::alien-record-field-name field)))
1859     (label-value-line slot (alien:slot alien slot)))))))))
1860    
1861     (defun inspect-alien-pointer (alien)
1862     (values
1863     (format nil "~A is an alien value." alien)
1864     (with-struct (alien::alien-value- sap type) alien
1865     (label-value-line*
1866     (:sap sap)
1867     (:type type)
1868     (:to (alien::deref alien))))))
1869    
1870     (defun inspect-alien-value (alien)
1871     (typecase (alien::alien-value-type alien)
1872     (alien::alien-record-type (inspect-alien-record alien))
1873     (alien::alien-pointer-type (inspect-alien-pointer alien))
1874     (t (scl-inspect alien))))
1875    
1876     ;;;; Profiling
1877     (defimplementation profile (fname)
1878     (eval `(profile:profile ,fname)))
1879    
1880     (defimplementation unprofile (fname)
1881     (eval `(profile:unprofile ,fname)))
1882    
1883     (defimplementation unprofile-all ()
1884     (eval `(profile:unprofile))
1885     "All functions unprofiled.")
1886    
1887     (defimplementation profile-report ()
1888     (eval `(profile:report-time)))
1889    
1890     (defimplementation profile-reset ()
1891     (eval `(profile:reset-time))
1892     "Reset profiling counters.")
1893    
1894     (defimplementation profiled-functions ()
1895     profile:*timed-functions*)
1896    
1897     (defimplementation profile-package (package callers methods)
1898     (profile:profile-all :package package
1899     :callers-p callers
1900     #+nil :methods #+nil methods))
1901    
1902    
1903     ;;;; Multiprocessing
1904    
1905     (defimplementation spawn (fn &key (name "Anonymous"))
1906     (thread:thread-create fn :name name))
1907    
1908     (defvar *thread-id-counter* 0)
1909     (defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter"))
1910    
1911     (defimplementation thread-id (thread)
1912     (thread:with-lock-held (*thread-id-counter-lock*)
1913     (or (getf (thread:thread-plist thread) 'id)
1914     (setf (getf (thread:thread-plist thread) 'id)
1915     (incf *thread-id-counter*)))))
1916    
1917     (defimplementation find-thread (id)
1918     (thread:map-over-threads
1919     #'(lambda (thread)
1920     (when (eql (getf (thread:thread-plist thread) 'id) id)
1921     (return-from find-thread thread)))))
1922    
1923     (defimplementation thread-name (thread)
1924     (princ-to-string (thread:thread-name thread)))
1925    
1926     (defimplementation thread-status (thread)
1927     (let ((dynamic-values (thread::thread-dynamic-values thread)))
1928     (if (zerop dynamic-values) "Exited" "Running")))
1929    
1930     (defimplementation make-lock (&key name)
1931     (thread:make-lock name))
1932    
1933     (defimplementation call-with-lock-held (lock function)
1934     (declare (type function function))
1935     (thread:with-lock-held (lock) (funcall function)))
1936    
1937     (defimplementation current-thread ()
1938     thread:*thread*)
1939    
1940     (defimplementation all-threads ()
1941     (let ((all-threads nil))
1942     (thread:map-over-threads #'(lambda (thread) (push thread all-threads)))
1943     all-threads))
1944    
1945     (defimplementation interrupt-thread (thread fn)
1946     (thread:thread-interrupt thread #'(lambda ()
1947     (sys:with-interrupts
1948     (funcall fn)))))
1949    
1950     (defimplementation kill-thread (thread)
1951     (thread:destroy-thread thread))
1952    
1953     (defimplementation thread-alive-p (thread)
1954     (not (zerop (thread::thread-dynamic-values thread))))
1955    
1956     (defvar *mailbox-lock* (thread:make-lock "Mailbox lock"))
1957    
1958     (defstruct (mailbox)
1959     (lock (thread:make-lock "Thread mailbox" :type :error-check)
1960     :type thread:error-check-lock)
1961     (cond-var (thread:make-cond-var "Thread mailbox") :type thread:cond-var)
1962     (queue '() :type list))
1963    
1964     (defun mailbox (thread)
1965     "Return 'thread's mailbox."
1966     (thread:with-lock-held (*mailbox-lock*)
1967     (or (getf (thread:thread-plist thread) 'mailbox)
1968     (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox)))))
1969    
1970     (defimplementation send (thread message)
1971     (let* ((mbox (mailbox thread))
1972     (lock (mailbox-lock mbox))
1973     (cond-var (mailbox-cond-var mbox)))
1974     (thread:with-lock-held (lock "Mailbox Send")
1975     (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) (list message)))
1976     (thread:cond-var-broadcast cond-var))
1977     message))
1978    
1979     (defimplementation receive ()
1980     (let* ((mbox (mailbox thread:*thread*))
1981     (lock (mailbox-lock mbox))
1982     (cond-var (mailbox-cond-var mbox)))
1983     (thread:with-lock-held (lock "Mailbox Receive")
1984     (loop
1985     (when (mailbox-queue mbox)
1986     (return (pop (mailbox-queue mbox))))
1987     (thread:cond-var-timedwait cond-var lock 10 "Mailbox receive wait")))))
1988    
1989    
1990    
1991     (defimplementation emacs-connected ())
1992    
1993    
1994     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1995     ;;Trace implementations
1996     ;; In SCL, we have:
1997     ;; (trace <name>)
1998     ;; (trace (method <name> <qualifier>? (<specializer>+)))
1999     ;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
2000     ;; <name> can be a normal name or a (setf name)
2001    
2002     (defun tracedp (spec)
2003     (member spec (eval '(trace)) :test #'equal))
2004    
2005     (defun toggle-trace-aux (spec &rest options)
2006     (cond ((tracedp spec)
2007     (eval `(untrace ,spec))
2008     (format nil "~S is now untraced." spec))
2009     (t
2010     (eval `(trace ,spec ,@options))
2011     (format nil "~S is now traced." spec))))
2012    
2013     (defimplementation toggle-trace (spec)
2014     (ecase (car spec)
2015     ((setf)
2016     (toggle-trace-aux spec))
2017     ((:defgeneric)
2018     (let ((name (second spec)))
2019     (toggle-trace-aux name :methods name)))
2020     ((:defmethod)
2021     nil)
2022     ((:call)
2023     (destructuring-bind (caller callee) (cdr spec)
2024     (toggle-trace-aux (process-fspec callee)
2025     :wherein (list (process-fspec caller)))))))
2026    
2027     (defun process-fspec (fspec)
2028     (cond ((consp fspec)
2029     (ecase (first fspec)
2030     ((:defun :defgeneric) (second fspec))
2031     ((:defmethod)
2032     `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
2033     ;; this isn't actually supported
2034     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
2035     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
2036     (t
2037     fspec)))
2038    
2039     ;;; Weak datastructures
2040    
2041     ;;; Not implemented in SCL.
2042     (defimplementation make-weak-key-hash-table (&rest args)
2043     (apply #'make-hash-table :weak-p t args))
2044    
2045     ;; Local Variables:
2046     ;; pbook-heading-regexp: "^;;;\\(;+\\)"
2047     ;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
2048     ;; End:

  ViewVC Help
Powered by ViewVC 1.1.5