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

Diff of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.60 by lgorrie, Sat Nov 22 05:36:59 2003 UTC revision 1.61 by lgorrie, Sun Nov 23 05:00:13 2003 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  ;;;; -*- Mode: lisp; outline-regexp: ";;;;*"; indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; swank.lisp --- the portable bits  ;;; swank.lisp --- the portable bits
4  ;;;  ;;;
# Line 7  Line 7 
7  ;;; This code has been placed in the Public Domain.  All warranties are  ;;; This code has been placed in the Public Domain.  All warranties are
8  ;;; disclaimed.  ;;; disclaimed.
9    
10    #+nil
11  (defpackage :swank  (defpackage :swank
12    (:use :common-lisp)    (:use :common-lisp)
   (:nicknames "SWANK-IMPL")  
13    (:export #:start-server #:create-swank-server    (:export #:start-server #:create-swank-server
14             #:*sldb-pprint-frames*))             #:*sldb-pprint-frames*))
15    
16  (in-package :swank)  (in-package :swank)
17    
18    ;; Directly exported backend functions.
19    (export '(arglist-string))
20    
21  (defvar *swank-io-package*  (defvar *swank-io-package*
22    (let ((package (make-package "SWANK-IO-PACKAGE")))    (let ((package (make-package "SWANK-IO-PACKAGE")))
23      (import '(nil t quote) package)      (import '(nil t quote) package)
# Line 294  change, then send Emacs an update." Line 297  change, then send Emacs an update."
297    
298  ;;;; Compilation Commands.  ;;;; Compilation Commands.
299    
 (defvar *previous-compiler-condition* nil  
   "Used to detect duplicates.")  
   
 (defvar *previous-context* nil  
   "Used for compiler warnings without context.")  
   
300  (defvar *compiler-notes* '()  (defvar *compiler-notes* '()
301    "List of compiler notes for the last compilation unit.")    "List of compiler notes for the last compilation unit.")
302    
303  (defun clear-compiler-notes ()  (defun clear-compiler-notes ()
304    (setf *compiler-notes* '())    (setf *compiler-notes* '()))
   (setf *previous-compiler-condition* nil)  
   (setf *previous-context* nil))  
   
 (defvar *notes-database* (make-hash-table :test #'equal)  
   "Database of recorded compiler notes/warnings/errors (keyed by filename).  
 Each value is a list of (LOCATION SEVERITY MESSAGE CONTEXT) lists.  
   LOCATION is a position in the source code (integer or source path).  
   SEVERITY is one of :ERROR, :WARNING, :STYLE-WARNING and :NOTE.  
   MESSAGE is a string describing the note.  
   CONTEXT is a string giving further details of where the error occured.")  
   
 (defun clear-note-database (filename)  
   (remhash (canonicalize-filename filename) *notes-database*))  
305    
306  (defslimefun features ()  (defslimefun features ()
307    (mapcar #'symbol-name *features*))    (mapcar #'symbol-name *features*))
# Line 325  Each value is a list of (LOCATION SEVERI Line 309  Each value is a list of (LOCATION SEVERI
309  (defun canonicalize-filename (filename)  (defun canonicalize-filename (filename)
310    (namestring (truename filename)))    (namestring (truename filename)))
311    
 (defslimefun compiler-notes-for-file (filename)  
   "Return the compiler notes recorded for FILENAME.  
 \(See *NOTES-DATABASE* for a description of the return type.)"  
   (gethash (canonicalize-filename filename) *notes-database*))  
   
312  (defslimefun compiler-notes-for-emacs ()  (defslimefun compiler-notes-for-emacs ()
313    "Return the list of compiler notes for the last compilation unit."    "Return the list of compiler notes for the last compilation unit."
314    (reverse *compiler-notes*))    (reverse *compiler-notes*))
# Line 343  The time is measured in microseconds." Line 322  The time is measured in microseconds."
322       (* (- (get-internal-real-time) before)       (* (- (get-internal-real-time) before)
323          (/ 1000000 internal-time-units-per-second)))))          (/ 1000000 internal-time-units-per-second)))))
324    
325  (defmacro with-trapping-compilation-notes (() &body body)  (defun record-note-for-condition (condition)
326    `(call-trapping-compilation-notes (lambda () ,@body)))    "Record a note for a compiler-condition."
327      (push (make-compiler-note condition) *compiler-notes*))
328    
329    (defun make-compiler-note (condition)
330      "Make a compiler note data structure from a compiler-condition."
331      (declare (type compiler-condition condition))
332      (list :message (message condition)
333            :severity (severity condition)
334            :location (location condition)))
335    
336  (defun call-with-compilation-hooks (fn)  (defslimefun swank-compile-file (filename load-p)
337      (clear-compiler-notes)
338    (multiple-value-bind (result usecs)    (multiple-value-bind (result usecs)
339        (with-trapping-compilation-notes ()        (handler-bind ((compiler-condition #'record-note-for-condition))
340          (clear-compiler-notes)          (measure-time-interval (lambda ()
341          (measure-time-interval fn))                                   (compile-file-for-emacs filename load-p))))
342        (list (to-string result)
343              (format nil "~,2F" (/ usecs 1000000.0)))))
344    
345    (defslimefun swank-compile-string (string buffer start)
346      (clear-compiler-notes)
347      (multiple-value-bind (result usecs)
348          (handler-bind ((compiler-condition #'record-note-for-condition))
349            (measure-time-interval
350             (lambda ()
351               (compile-string-for-emacs string :buffer buffer :position start))))
352      (list (to-string result)      (list (to-string result)
353            (format nil "~,2F" (/ usecs 1000000.0)))))            (format nil "~,2F" (/ usecs 1000000.0)))))
354    
# Line 408  The time is measured in microseconds." Line 406  The time is measured in microseconds."
406  (defslimefun disassemble-symbol (symbol-name)  (defslimefun disassemble-symbol (symbol-name)
407    (print-output-to-string (lambda () (disassemble (from-string symbol-name)))))    (print-output-to-string (lambda () (disassemble (from-string symbol-name)))))
408    
409    (defslimefun swank-macroexpand-all (string)
410      (apply-macro-expander #'macroexpand-all string))
411    
412  ;;; Completion  ;;; Completion
413    
414  (defun case-convert (string)  (defun case-convert (string)
# Line 513  The result is a list of property lists." Line 514  The result is a list of property lists."
514            (sort (apropos-symbols name external-only package)            (sort (apropos-symbols name external-only package)
515                  #'present-symbol-before-p)))                  #'present-symbol-before-p)))
516    
517    (defun briefly-describe-symbol-for-emacs (symbol)
518      "Return a property list describing SYMBOL.
519    Like `describe-symbol-for-emacs' but with at most one line per item."
520      (flet ((first-line (string)
521               (let ((pos (position #\newline string)))
522                 (if (null pos) string (subseq string 0 pos)))))
523        (list* :designator (to-string symbol)
524               (map-if #'stringp #'first-line (describe-symbol-for-emacs symbol)))))
525    
526    (defun map-if (test fn &rest lists)
527      "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
528    Example:
529    \(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
530      (apply #'mapcar
531             (lambda (x) (if (funcall test x) (funcall fn x) x))
532             lists))
533    
534  (defun listify (f)  (defun listify (f)
535    "Return a function like F, but which returns any non-null value    "Return a function like F, but which returns any non-null value
536  wrapped in a list."  wrapped in a list."

Legend:
Removed from v.1.60  
changed lines
  Added in v.1.61

  ViewVC Help
Powered by ViewVC 1.1.5