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

Diff of /slime/swank.lisp

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

revision 1.765 by heller, Tue Nov 29 19:50:16 2011 UTC revision 1.766 by heller, Thu Dec 1 16:48:21 2011 UTC
# Line 540  corresponding values in the CDR of VALUE Line 540  corresponding values in the CDR of VALUE
540                        `(,getter ,',var))))                        `(,getter ,',var))))
541           ,@body))))           ,@body))))
542    
 (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)  
   "Just like do-symbols, but makes sure a symbol is visited only once."  
   (let ((seen-ht (gensym "SEEN-HT")))  
     `(let ((,seen-ht (make-hash-table :test #'eq)))  
       (do-symbols (,var ,package ,result-form)  
         (unless (gethash ,var ,seen-ht)  
           (setf (gethash ,var ,seen-ht) t)  
           (tagbody ,@body))))))  
   
543  (defmacro define-special (name doc)  (defmacro define-special (name doc)
544    "Define a special variable NAME with doc string DOC.    "Define a special variable NAME with doc string DOC.
545  This is like defvar, but NAME will not be initialized."  This is like defvar, but NAME will not be initialized."
# Line 650  about internal symbols most times. As th Line 641  about internal symbols most times. As th
641  If PACKAGE is not specified, the home package of SYMBOL is used."  If PACKAGE is not specified, the home package of SYMBOL is used."
642    (eq (symbol-status symbol package) :external))    (eq (symbol-status symbol package) :external))
643    
   
 (defun classify-symbol (symbol)  
   "Returns a list of classifiers that classify SYMBOL according to its  
 underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special  
 variable.) The list may contain the following classification  
 keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,  
 :TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"  
   (check-type symbol symbol)  
   (flet ((type-specifier-p (s)  
            (or (documentation s 'type)  
                (not (eq (type-specifier-arglist s) :not-available)))))  
     (let (result)  
       (when (boundp symbol)             (push (if (constantp symbol)  
                                                   :constant :boundp) result))  
       (when (fboundp symbol)            (push :fboundp result))  
       (when (type-specifier-p symbol)   (push :typespec result))  
       (when (find-class symbol nil)     (push :class result))  
       (when (macro-function symbol)     (push :macro result))  
       (when (special-operator-p symbol) (push :special-operator result))  
       (when (find-package symbol)       (push :package result))  
       (when (and (fboundp symbol)  
                  (typep (ignore-errors (fdefinition symbol))  
                         'generic-function))  
         (push :generic-function result))  
   
       result)))  
   
 (defun symbol-classification-string (symbol)  
   "Return a string in the form -f-c---- where each letter stands for  
 boundp fboundp generic-function class macro special-operator package"  
   (let ((letters "bfgctmsp")  
         (result (copy-seq "--------")))  
     (flet ((type-specifier-p (s)  
              (or (documentation s 'type)  
                  (not (eq (type-specifier-arglist s) :not-available))))  
            (flip (letter)  
              (setf (char result (position letter letters))  
                    letter)))  
       (when (boundp symbol) (flip #\b))  
       (when (fboundp symbol)  
         (flip #\f)  
         (when (typep (ignore-errors (fdefinition symbol))  
                      'generic-function)  
           (flip #\g)))  
       (when (type-specifier-p symbol) (flip #\t))  
       (when (find-class symbol nil)   (flip #\c) )  
       (when (macro-function symbol)   (flip #\m))  
       (when (special-operator-p symbol) (flip #\s))  
       (when (find-package symbol)       (flip #\p))  
       result)))  
   
644    
645  ;;;; TCP Server  ;;;; TCP Server
646    
# Line 1862  Emacs buffer." Line 1802  Emacs buffer."
1802         ,(cond ((and stream object)         ,(cond ((and stream object)
1803                 (let ((gstream (gensym "STREAM+")))                 (let ((gstream (gensym "STREAM+")))
1804                   `(let ((,gstream ,stream))                   `(let ((,gstream ,stream))
1805                      (print-unreadable-object (,object ,gstream :type t :identity t)                      (print-unreadable-object (,object ,gstream :type t
1806                                                          :identity t)
1807                        (write-string ,msg ,gstream)))))                        (write-string ,msg ,gstream)))))
1808                (stream                (stream
1809                 `(write-string ,msg ,stream))                 `(write-string ,msg ,stream))
# Line 2675  TAGS has is a list of strings." Line 2616  TAGS has is a list of strings."
2616    
2617  (defun frame-locals-for-emacs (index)  (defun frame-locals-for-emacs (index)
2618    (with-bindings *backtrace-printer-bindings*    (with-bindings *backtrace-printer-bindings*
2619      (loop for var in (frame-locals index) collect      (loop for var in (frame-locals index) collect
2620            (destructuring-bind (&key name id value) var            (destructuring-bind (&key name id value) var
2621              (list :name (prin1-to-string name)              (list :name (prin1-to-string name)
2622                    :id id                    :id id
# Line 2703  TAGS has is a list of strings." Line 2644  TAGS has is a list of strings."
2644              (setq *sldb-stepping-p* t)              (setq *sldb-stepping-p* t)
2645              (continue))              (continue))
2646             (t             (t
2647              (error "Not currently single-stepping, and no continue restart available.")))))              (error "Not currently single-stepping, ~
2648    and no continue restart available.")))))
2649    
2650  (define-stepper-function sldb-step sldb-step-into)  (define-stepper-function sldb-step sldb-step-into)
2651  (define-stepper-function sldb-next sldb-step-next)  (define-stepper-function sldb-next sldb-step-next)

Legend:
Removed from v.1.765  
changed lines
  Added in v.1.766

  ViewVC Help
Powered by ViewVC 1.1.5