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

Diff of /slime/swank.lisp

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

revision 1.249 by pseibel, Thu Oct 7 19:33:00 2004 UTC revision 1.250 by heller, Sun Oct 17 18:10:03 2004 UTC
# Line 22  Line 22 
22             #:print-indentation-lossage             #:print-indentation-lossage
23             #:swank-debugger-hook             #:swank-debugger-hook
24             ;; These are user-configurable variables:             ;; These are user-configurable variables:
            #:*sldb-pprint-frames*  
25             #:*communication-style*             #:*communication-style*
26             #:*log-events*             #:*log-events*
27             #:*use-dedicated-output-stream*             #:*use-dedicated-output-stream*
# Line 75  Line 74 
74  (defvar *swank-debug-p* t  (defvar *swank-debug-p* t
75    "When true, print extra debugging information.")    "When true, print extra debugging information.")
76    
 (defvar *sldb-pprint-frames* nil  
   "*pretty-print* is bound to this value when sldb prints a frame.")  
   
77  ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via  ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
78  ;;; RPC.  ;;; RPC.
79    
80  (defmacro defslimefun (name arglist &body rest)  (defmacro defslimefun (name arglist &body rest)
81    "A DEFUN for functions that Emacs can call by RPC."    "A DEFUN for functions that Emacs can call by RPC."
82    `(progn    `(progn
83      (defun ,name ,arglist ,@rest)       (defun ,name ,arglist ,@rest)
84      ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>       ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
85      (eval-when (:compile-toplevel :load-toplevel :execute)       (eval-when (:compile-toplevel :load-toplevel :execute)
86        (export ',name :swank))))         (export ',name :swank))))
87    
88  (declaim (ftype (function () nil) missing-arg))  (declaim (ftype (function () nil) missing-arg))
89  (defun missing-arg ()  (defun missing-arg ()
# Line 245  corresponding values in the CDR of VALUE Line 241  corresponding values in the CDR of VALUE
241      `(let* ((,tmp ,value)      `(let* ((,tmp ,value)
242              (,operator (car ,tmp))              (,operator (car ,tmp))
243              (,operands (cdr ,tmp)))              (,operands (cdr ,tmp)))
244        (case ,operator         (case ,operator
245          ,@(mapcar (lambda (clause)           ,@(loop for (pattern . body) in patterns collect
246                      (if (eq (car clause) t)                     (if (eq pattern t)
247                          `(t ,@(cdr clause))                         `(t ,@body)
248                          (destructuring-bind ((op &rest rands) &rest body)                         (destructuring-bind (op &rest rands) pattern
249                              clause                           `(,op (destructuring-bind ,rands ,operands
250                            `(,op (destructuring-bind ,rands ,operands                                   ,@body)))))
251                                    . ,body)))))           ,@(if (eq (caar (last patterns)) t)
252                    patterns)                 '()
253          ,@(if (eq (caar (last patterns)) t)                 `((t (error "destructure-case failed: ~S" ,tmp))))))))
               '()  
               `((t (error "destructure-case failed: ~S" ,tmp))))))))  
254    
255  (defmacro with-temp-package (var &body body)  (defmacro with-temp-package (var &body body)
256    "Execute BODY with VAR bound to a temporary package.    "Execute BODY with VAR bound to a temporary package.
257  The package is deleted before returning."  The package is deleted before returning."
258    `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))    `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
259      (unwind-protect (progn ,@body)       (unwind-protect (progn ,@body)
260        (delete-package ,var))))         (delete-package ,var))))
261    
262  ;;;; TCP Server  ;;;; TCP Server
263    
# Line 418  of the toplevel restart." Line 412  of the toplevel restart."
412    
413  (defmacro with-reader-error-handler ((connection) &body body)  (defmacro with-reader-error-handler ((connection) &body body)
414    `(handler-case (progn ,@body)    `(handler-case (progn ,@body)
415      (slime-protocol-error (e)       (slime-protocol-error (e)
416       (close-connection ,connection e))))         (close-connection ,connection e))))
417    
418  (defun simple-break ()  (defun simple-break ()
419    (with-simple-restart  (continue "Continue from interrupt.")    (with-simple-restart  (continue "Continue from interrupt.")
# Line 701  dynamic binding." Line 695  dynamic binding."
695    (let ((real-stream-var (prefixed-var "REAL" stream-var))    (let ((real-stream-var (prefixed-var "REAL" stream-var))
696          (current-stream-var (prefixed-var "CURRENT" stream-var)))          (current-stream-var (prefixed-var "CURRENT" stream-var)))
697      `(progn      `(progn
698        ;; Save the real stream value for the future.         ;; Save the real stream value for the future.
699        (defvar ,real-stream-var ,stream-var)         (defvar ,real-stream-var ,stream-var)
700        ;; Define a new variable for the effective stream.         ;; Define a new variable for the effective stream.
701        ;; This can be reassigned.         ;; This can be reassigned.
702        (defvar ,current-stream-var ,stream-var)         (defvar ,current-stream-var ,stream-var)
703        ;; Assign the real binding as a synonym for the current one.         ;; Assign the real binding as a synonym for the current one.
704        (setq ,stream-var (make-synonym-stream ',current-stream-var)))))         (setq ,stream-var (make-synonym-stream ',current-stream-var)))))
705    
706  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
707    (defun prefixed-var (prefix variable-symbol)    (defun prefixed-var (prefix variable-symbol)
# Line 900  If a protocol error occurs then a SLIME- Line 894  If a protocol error occurs then a SLIME-
894  (defun read-user-input-from-emacs ()  (defun read-user-input-from-emacs ()
895    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))    (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*)))
896      (force-output)      (force-output)
897      (send-to-emacs `(:read-string ,(current-thread)      (send-to-emacs `(:read-string ,(current-thread) ,*read-input-catch-tag*))
                      ,*read-input-catch-tag*))  
898      (let ((ok nil))      (let ((ok nil))
899        (unwind-protect        (unwind-protect
900             (prog1 (catch (intern-catch-tag *read-input-catch-tag*)             (prog1 (catch (intern-catch-tag *read-input-catch-tag*)
# Line 909  If a protocol error occurs then a SLIME- Line 902  If a protocol error occurs then a SLIME-
902               (setq ok t))               (setq ok t))
903          (unless ok          (unless ok
904            (send-to-emacs `(:read-aborted ,(current-thread)            (send-to-emacs `(:read-aborted ,(current-thread)
905                             *read-input-catch-tag*)))))))                                           *read-input-catch-tag*)))))))
906    
907  (defslimefun take-input (tag input)  (defslimefun take-input (tag input)
908    "Return the string INPUT to the continuation TAG."    "Return the string INPUT to the continuation TAG."
# Line 949  This should be used for code that is con Line 942  This should be used for code that is con
942  Emacs buffer."  Emacs buffer."
943    (destructuring-bind () _    (destructuring-bind () _
944      `(let ((*package* *buffer-package*))      `(let ((*package* *buffer-package*))
945        ;; Don't shadow *readtable* unnecessarily because that prevents         ;; Don't shadow *readtable* unnecessarily because that prevents
946        ;; the user from assigning to it.         ;; the user from assigning to it.
947        (if (eq *readtable* *buffer-readtable*)         (if (eq *readtable* *buffer-readtable*)
948            #1=(call-with-syntax-hooks (lambda () ,@body))             #1=(call-with-syntax-hooks (lambda () ,@body))
949            (let ((*readtable* *buffer-readtable*))             (let ((*readtable* *buffer-readtable*))
950              #1#)))))               #1#)))))
951    
952  (defun from-string (string)  (defun from-string (string)
953    "Read string in the *BUFFER-PACKAGE*"    "Read string in the *BUFFER-PACKAGE*"
# Line 1158  Errors are trapped and invoke our debugg Line 1151  Errors are trapped and invoke our debugg
1151               (setq ok t))               (setq ok t))
1152          (force-user-output)          (force-user-output)
1153          (send-to-emacs `(:return ,(current-thread)          (send-to-emacs `(:return ,(current-thread)
1154                           ,(if ok `(:ok ,result) '(:abort))                                   ,(if ok `(:ok ,result) '(:abort))
1155                           ,id))))))                                   ,id))))))
1156    
1157  (defun format-values-for-echo-area (values)  (defun format-values-for-echo-area (values)
1158    (with-buffer-syntax ()    (with-buffer-syntax ()
# Line 1236  change, then send Emacs an update." Line 1229  change, then send Emacs an update."
1229          (makunbound name)          (makunbound name)
1230          (prin1-to-string (eval form))))))          (prin1-to-string (eval form))))))
1231    
1232  (defvar *swank-pprint-circle* *print-circle*  (defun foo (&key ((:x a)) ((y b)))
1233    "*PRINT-CIRCLE* is bound to this value when pretty printing slime output.")    (cons a b))
   
 (defvar *swank-pprint-case* *print-case*  
   "*PRINT-CASE* is bound to this value when pretty printing slime output.")  
1234    
1235  (defvar *swank-pprint-right-margin* *print-right-margin*  (foo 'y 10)
   "*PRINT-RIGHT-MARGIN* is bound to this value when pretty printing slime output.")  
1236    
 (defvar *swank-pprint-escape* *print-escape*  
   "*PRINT-ESCAPE* is bound to this value when pretty printing slime output.")  
1237    
1238  (defvar *swank-pprint-level* *print-level*  (defmacro define-printer-variables (prefix &body vars)
1239    "*PRINT-LEVEL* is bound to this value when pretty printing slime output.")    "Define a group of printer variables.
1240    
1241  (defvar *swank-pprint-length* *print-length*  The elements of VARS can have the form: NAME or (NAME INIT).  NAME
1242    "*PRINT-LENGTH* is bound to this value when pretty printing slime output.")  must be one of the symbols (pretty circle case escape right-margin
1243    level length).  PREFIX and NAME are concatenated, like *PREFIX-NAME*,
1244    to form the names of the actual variable.  The new variable is
1245    initialized with INIT or, if INIT was not specified, with the value of
1246    the corresponding printer variable.
1247    
1248    At macroexpansion time the names of the created symbols are stored in
1249    the 'printer-variables property of PREFIX."
1250      (let ((valid-names '(level length circle readably pretty
1251                           case escape right-margin)))
1252        (labels ((symconc (prefix suffix)
1253                   (intern (format nil "*~A-~A*" (string prefix) (string suffix))
1254                           :swank))
1255                 (parse (var)
1256                   (destructuring-bind (name init &optional doc)
1257                       (if (consp var)  var  (list var (symconc 'print var)))
1258                     (unless (member name valid-names)
1259                       (error "Not a printer variable: ~S" var))
1260                     (list name init doc))))
1261          (let* ((bindings (mapcar #'parse vars)))
1262            (setf (get prefix 'printer-variables)
1263                  (loop for (name) in bindings
1264                        collect `(,(symconc 'print name) ,(symconc prefix name))))
1265            `(progn
1266               ,@(loop for (name init doc) in bindings
1267                       collect `(defvar ,(symconc prefix name) ,init ,doc)))))))
1268    
1269    (define-printer-variables swank-pprint
1270      circle level length case right-margin escape)
1271    
1272    (defmacro with-printer-settings (group &body body)
1273      "Rebind the pringer variables in GROUP and execute body.
1274    See `define-printer-variables'."
1275      (let ((bindings (get group 'printer-variables)))
1276        (when (not bindings) (warn "No printer variables for: ~S" group))
1277        `(let ,bindings ,@body)))
1278    
1279  (defun swank-pprint (list)  (defun swank-pprint (list)
1280    "Bind some printer variables and pretty print each object in LIST."    "Bind some printer variables and pretty print each object in LIST."
1281    (with-buffer-syntax ()    (with-buffer-syntax ()
1282      (let ((*print-pretty* t)      (with-printer-settings swank-pprint
1283            (*print-case* *swank-pprint-case*)        (let ((*print-pretty* t))
1284            (*print-right-margin* *swank-pprint-right-margin*)          (cond ((null list) "; No value")
1285            (*print-circle* *swank-pprint-circle*)                (t (with-output-to-string (*standard-output*)
1286            (*print-escape* *swank-pprint-escape*)                     (dolist (o list)
1287            (*print-level* *swank-pprint-level*)                       (pprint o)
1288            (*print-length* *swank-pprint-length*))                       (terpri)))))))))
1289        (cond ((null list) "; No value")  
             (t (with-output-to-string (*standard-output*)  
                  (dolist (o list)  
                    (pprint o)  
                    (terpri))))))))  
   
1290  (defslimefun pprint-eval (string)  (defslimefun pprint-eval (string)
1291    (with-buffer-syntax ()    (with-buffer-syntax ()
1292      (swank-pprint (multiple-value-list (eval (read-from-string string))))))      (swank-pprint (multiple-value-list (eval (read-from-string string))))))
# Line 1348  after Emacs causes a restart to be invok Line 1365  after Emacs causes a restart to be invok
1365  (defvar *sldb-restarts* nil  (defvar *sldb-restarts* nil
1366    "The list of currenlty active restarts.")    "The list of currenlty active restarts.")
1367    
1368    ;; A set of printer variables used in the debugger.
1369    (define-printer-variables sldb
1370      (pretty nil)
1371      (level 4)
1372      (length 10)
1373      (circle t)
1374      (readably nil))
1375    
1376  (defun debug-in-emacs (condition)  (defun debug-in-emacs (condition)
1377    (let ((*swank-debugger-condition* condition)    (let ((*swank-debugger-condition* condition)
1378          (*sldb-restarts* (compute-restarts condition))          (*sldb-restarts* (compute-restarts condition))
# Line 1355  after Emacs causes a restart to be invok Line 1380  after Emacs causes a restart to be invok
1380                              (symbol-value '*buffer-package*))                              (symbol-value '*buffer-package*))
1381                         *package*))                         *package*))
1382          (*sldb-level* (1+ *sldb-level*))          (*sldb-level* (1+ *sldb-level*))
1383          (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))          (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
         (*print-readably* nil))  
1384      (force-user-output)      (force-user-output)
1385      (call-with-debugging-environment      (with-printer-settings sldb
1386       (lambda () (sldb-loop *sldb-level*)))))        (call-with-debugging-environment
1387           (lambda () (sldb-loop *sldb-level*))))))
1388    
1389  (defun sldb-loop (level)  (defun sldb-loop (level)
1390    (unwind-protect    (unwind-protect
# Line 1381  Rather than recursively debug the debugg Line 1406  Rather than recursively debug the debugg
1406  conditions are simply reported."  conditions are simply reported."
1407    (let ((real-condition (original-condition condition)))    (let ((real-condition (original-condition condition)))
1408      (send-to-emacs `(:debug-condition ,(current-thread)      (send-to-emacs `(:debug-condition ,(current-thread)
1409                       ,(princ-to-string real-condition))))                                        ,(princ-to-string real-condition))))
1410    (throw 'sldb-loop-catcher nil))    (throw 'sldb-loop-catcher nil))
1411    
1412  (defun safe-condition-message (condition)  (defun safe-condition-message (condition)
# Line 1413  format suitable for Emacs." Line 1438  format suitable for Emacs."
1438  (defun frame-for-emacs (n frame)  (defun frame-for-emacs (n frame)
1439    (let* ((label (format nil "  ~D: " n))    (let* ((label (format nil "  ~D: " n))
1440           (string (with-output-to-string (stream)           (string (with-output-to-string (stream)
                    (let ((*print-pretty* *sldb-pprint-frames*)  
                          (*print-circle* t))  
1441                       (princ label stream)                       (princ label stream)
1442                       (print-frame frame stream)))))                       (print-frame frame stream))))
1443      (subseq string (length label))))      (subseq string (length label))))
1444    
1445  ;;;;; SLDB entry points  ;;;;; SLDB entry points
# Line 1501  has changed, ignore the request." Line 1524  has changed, ignore the request."
1524  (defslimefun frame-locals-for-emacs (index)  (defslimefun frame-locals-for-emacs (index)
1525    "Return a property list ((&key NAME ID VALUE) ...) describing    "Return a property list ((&key NAME ID VALUE) ...) describing
1526  the local variables in the frame INDEX."  the local variables in the frame INDEX."
1527    (let* ((*print-readably* nil)    (let* ((*package* (or (frame-package index) *package*)))
          (*print-pretty* *sldb-pprint-frames*)  
          (*print-circle* t)  
          (*package* (or (frame-package index) *package*)))  
1528      (mapcar (lambda (frame-locals)      (mapcar (lambda (frame-locals)
1529                (destructuring-bind (&key name id value) frame-locals                (destructuring-bind (&key name id value) frame-locals
1530                  (list :name (prin1-to-string name) :id id                  (list :name (prin1-to-string name) :id id
# Line 2546  The result is a list of the form ((LOCAT Line 2566  The result is a list of the form ((LOCAT
2566    
2567  (defmethod inspect-for-emacs ((object cons) (inspector t))  (defmethod inspect-for-emacs ((object cons) (inspector t))
2568    (declare (ignore inspector))    (declare (ignore inspector))
2569    (if (listp object)    (if (consp (cdr object))
2570        (inspect-for-emacs-list object)        (inspect-for-emacs-list object)
2571        (inspect-for-emacs-simple-cons object)))        (inspect-for-emacs-simple-cons object)))
2572    
2573  (defun inspect-for-emacs-simple-cons (cons)  (defun inspect-for-emacs-simple-cons (cons)
2574    (values "A cons cell."    (values "A cons cell."
2575            `("Car: " (:value ,(car cons))            (label-value-line*
2576              (:newline)             ('car (car cons))
2577              "Cdr: " (:value ,(cdr cons)))))             ('cdr (cdr cons)))))
2578    
2579  (defun inspect-for-emacs-list (list)  (defun inspect-for-emacs-list (list)
2580    (let ((circularp nil)    (let ((maxlen 40))
2581          (length 0)      (multiple-value-bind (length tail) (safe-length list)
2582          (seen (make-hash-table :test 'eq))        (flet ((frob (title list &rest rest)
2583          (contents '()))                 (values title
2584      (loop                         (append '("Elements:" (:newline))
2585         for cons on list                                 (loop for i from 0
2586         when (gethash cons seen)                                       for e in list
2587           do (setf circularp t) and                                       append (label-value-line i e))
2588           do (return)                                 rest))))
2589         do (push '(:newline) contents)          (cond ((not length)             ; circular
2590         do (push `(:value ,(car cons)) contents)                 (frob "A circular list."
2591         do (setf (gethash cons seen) t)                       (cons (car list)
2592         do (incf length))                             (ldiff (cdr list) list))))
2593      (if circularp                ((and (<= length maxlen) (not tail))
2594          (values "A circular list."                 (frob "A proper list." list))
2595                  `("Contents:"                (tail
2596                    ,@(nreverse contents)))                 (frob "An improper list."
2597          (values "A proper list."                       (subseq list 0 length)
2598                  `("Length: " (:value ,length)                       (list :value tail "tail")))
2599                    (:newline)                (t
2600                    "Contents:"                 (frob "A proper list."
2601                    ,@(nreverse contents))))))                       (subseq list 0 maxlen)
2602                         (list :value (nthcdr maxlen list) "rest"))))))))
2603    
2604    (defun safe-length (list)
2605      "Similar to `list-length', but avoid errors on improper lists.
2606    Return two values: the length of the list and the last cdr.
2607    NIL is returned if the list is circular."
2608      (do ((n 0 (+ n 2))                    ;Counter.
2609           (fast list (cddr fast))          ;Fast pointer: leaps by 2.
2610           (slow list (cdr slow)))          ;Slow pointer: leaps by 1.
2611          (nil)
2612        (cond ((null fast) (return (values n nil)))
2613              ((not (consp fast)) (return (values n fast)))
2614              ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
2615              ((and (eq fast slow) (> n 0)) (return nil))
2616              ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
2617    
2618  (defmethod inspect-for-emacs ((ht hash-table) (inspector t))  (defmethod inspect-for-emacs ((ht hash-table) (inspector t))
2619    (declare (ignore inspector))    (declare (ignore inspector))
2620    (values "A hash table."    (values "A hash table."
2621            `("Count: " (:value ,(hash-table-count ht))            (append
2622              (:newline)             (label-value-line*
2623              "Size: " (:value ,(hash-table-size ht))              ("Count" (hash-table-count ht))
2624              (:newline)              ("Size" (hash-table-size ht))
2625              "Test: " (:value ,(hash-table-test ht))              ("Test" (hash-table-test ht))
2626              (:newline)              ("Rehash size" (hash-table-rehash-size ht))
2627              "Rehash size: " (:value ,(hash-table-rehash-size ht))              ("Rehash threshold" (hash-table-rehash-threshold ht)))
2628              (:newline)             '("Contents: " (:newline))
2629              "Rehash threshold: " (:value ,(hash-table-rehash-threshold ht))             (loop for key being the hash-keys of ht
             (:newline)  
             "Contents:" (:newline)  
             ,@(loop  
                  for key being the hash-keys of ht  
2630                   for value being the hash-values of ht                   for value being the hash-values of ht
2631                   collect `(:value ,key)                   append `((:value ,key) " = " (:value ,value) (:newline))))))
                  collect " = "  
                  collect `(:value ,value)  
                  collect " "  
                  collect `(:newline)))))  
2632    
2633  (defmethod inspect-for-emacs ((array array) (inspector t))  (defmethod inspect-for-emacs ((array array) (inspector t))
2634    (declare (ignore inspector))    (declare (ignore inspector))
2635    (values "An array."    (values "An array."
2636            `("Dimensions: " (:value ,(array-dimensions array))            (append
2637              (:newline)             (label-value-line*
2638              "Its element type is: " (:value ,(array-element-type array))              ("Dimensions" (array-dimensions array))
2639              (:newline)              ("Its element type is" (array-element-type array))
2640              "Total size: " (:value ,(array-total-size array))              ("Total size" (array-total-size array))
2641              (:newline)              ("Fill pointer" (fill-pointer array))
2642              ,@(if (array-has-fill-pointer-p array)              ("Adjustable" (adjustable-array-p array)))
2643                    `("Its fill-pointer is " (:value ,(fill-pointer array)))             '("Contents:" (:newline))
2644                    `("No fill pointer."))             (let ((darray (make-array (array-total-size array)
2645              (:newline)                                       :displaced-to array
2646              ,(if (adjustable-array-p array)                                       :displaced-index-offset 0)))
2647                   "It is adjustable."               (loop for e across darray
2648                   "It is not adjustable.")                     for i from 0
2649              (:newline)                     collect (label-value-line i e))))))
             "Contents:" (:newline)  
             ,@(loop  
                  with darray = (make-array (array-total-size array)  
                                            :displaced-to array  
                                            :displaced-index-offset 0  
                                            :element-type (array-element-type array))  
                  for index upfrom 0  
                  for element across darray  
                  collect `(:value ,element)  
                  collect '(:newline)))))  
2650    
2651  (defmethod inspect-for-emacs ((char character) (inspector t))  (defmethod inspect-for-emacs ((char character) (inspector t))
2652    (declare (ignore inspector))    (declare (ignore inspector))
2653    (values "A character."    (values "A character."
2654            `("Char code: " (:value ,(char-code char))            (append
2655              (:newline)             (label-value-line*
2656              "Lower cased: " (:value ,(char-downcase char))              ("Char code" (char-code char))
2657              (:newline)              ("Lower cased" (char-downcase char))
2658              "Upper cased: " (:value ,(char-upcase char))              ("Upper cased" (char-upcase char)))
2659              (:newline)             (if (get-macro-character char)
2660              ,@(when (get-macro-character char)                 `("In the current readtable ("
2661                  `("In the current readtable (" (:value ,*readtable*) ") it is a macro character: "                   (:value ,*readtable*) ") it is a macro character: "
2662                    (:value ,(get-macro-character char))                   (:value ,(get-macro-character char)))))))
                   (:newline))))))  
2663    
2664    ;; Shouldn't most of this stuff be done by describe-symbol-for-emacs? -- he
2665  (defmethod inspect-for-emacs ((symbol symbol) (inspector t))  (defmethod inspect-for-emacs ((symbol symbol) (inspector t))
2666    (declare (ignore inspector))    (declare (ignore inspector))
2667    (let ((internal-external (multiple-value-bind (symbol status)    (let ((internal-external (multiple-value-bind (symbol status)
# Line 2932  The result is a list of the form ((LOCAT Line 2949  The result is a list of the form ((LOCAT
2949  (defmethod inspect-for-emacs ((pathname logical-pathname) (inspector t))  (defmethod inspect-for-emacs ((pathname logical-pathname) (inspector t))
2950    (declare (ignore inspector))    (declare (ignore inspector))
2951    (values "A logical pathname."    (values "A logical pathname."
2952            `("Namestring: " (:value ,(namestring pathname))            (append
2953              (:newline)             (label-value-line*
2954              "Physical pathname: " (:value ,(translate-logical-pathname pathname))              ("Namestring" (namestring pathname))
2955              (:newline)              ("Physical pathname: " (translate-logical-pathname pathname)))
2956              "Host: " (:value ,(pathname-host pathname))             `("Host: " (pathname-host pathname)
2957              " (" (:value ,(logical-pathname-translations (pathname-host pathname)) "other translations") ")"                      " (" (:value ,(logical-pathname-translations
2958              (:newline)                                     (pathname-host pathname)))
2959              "Directory: " (:value ,(pathname-directory pathname))                      "other translations)"
2960              (:newline)                      (:newline))
2961              "Name: " (:value ,(pathname-name pathname))             (label-value-line*
2962              (:newline)              ("Directory" (pathname-directory pathname))
2963              "Type: " (:value ,(pathname-type pathname))              ("Name" (pathname-name pathname))
2964              (:newline)              ("Type" (pathname-type pathname))
2965              "Version: " (:value ,(pathname-version pathname))              ("Version" (pathname-version pathname))
2966              ,@(unless (or (wild-pathname-p pathname)              ("Truename" (if (not (wild-pathname-p pathname))
2967                            (not (probe-file pathname)))                              (probe-file pathname)))))))
                 `((:newline)  
                   "Truename: " (:value ,(truename pathname)))))))  
2968    
2969  (defmethod inspect-for-emacs ((n number) (inspector t))  (defmethod inspect-for-emacs ((n number) (inspector t))
2970    (declare (ignore inspector))    (declare (ignore inspector))
# Line 2959  The result is a list of the form ((LOCAT Line 2974  The result is a list of the form ((LOCAT
2974    (declare (ignore inspector))    (declare (ignore inspector))
2975    (values "A number."    (values "A number."
2976            (append            (append
2977             `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8B = ~E" i i i i i) (:newline))             `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8B = ~E"
2978                          i i i i i)
2979                  (:newline))
2980             (if (< -1 i char-code-limit)             (if (< -1 i char-code-limit)
2981                 (label-value-line "Corresponding character" (code-char i)))                 (label-value-line "Corresponding character" (code-char i)))
2982             (label-value-line "Length" (integer-length i))             (label-value-line "Length" (integer-length i))
# Line 3245  belonging to the buffer package." Line 3262  belonging to the buffer package."
3262                 (when indent                 (when indent
3263                   (unless (equal (gethash symbol cache) indent)                   (unless (equal (gethash symbol cache) indent)
3264                     (setf (gethash symbol cache) indent)                     (setf (gethash symbol cache) indent)
3265                     (dolist (readname (all-qualified-readnames symbol))                     (push (cons (string-downcase symbol) indent) alist))))))
                      (push (cons readname indent) alist)))))))  
3266        (if force        (if force
3267            (do-all-symbols (symbol)            (do-all-symbols (symbol)
3268              (consider symbol))              (consider symbol))
# Line 3255  belonging to the buffer package." Line 3271  belonging to the buffer package."
3271                (consider symbol)))))                (consider symbol)))))
3272      alist))      alist))
3273    
 (defun all-qualified-readnames (symbol)  
   "Return the list of SYMBOL's readnames with each package qualifier.  
 The resulting strings are always downcase (for Emacs indentation)."  
   (cons (symbol-name symbol)  
         (loop for p in (package-names (symbol-package symbol))  
               collect (format nil "~A:~A"  
                               (string-downcase p)  
                               (string-downcase (symbol-name symbol))))))  
   
3274  (defun package-names (package)  (defun package-names (package)
3275    "Return the name and all nicknames of PACKAGE in a list."    "Return the name and all nicknames of PACKAGE in a list."
3276    (cons (package-name package) (package-nicknames package)))    (cons (package-name package) (package-nicknames package)))

Legend:
Removed from v.1.249  
changed lines
  Added in v.1.250

  ViewVC Help
Powered by ViewVC 1.1.5