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

Diff of /slime/swank.lisp

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

revision 1.101 by heller, Fri Jan 16 21:28:59 2004 UTC revision 1.102 by heller, Fri Jan 16 21:49:29 2004 UTC
# Line 1084  that symbols accessible in the current p Line 1084  that symbols accessible in the current p
1084  (defslimefun throw-to-toplevel ()  (defslimefun throw-to-toplevel ()
1085    (throw 'slime-toplevel nil))    (throw 'slime-toplevel nil))
1086    
1087  ;;; Source Locations  
1088    ;;;; Source Locations
1089    
1090  (defstruct (:location (:type list) :named  (defstruct (:location (:type list) :named
1091                        (:constructor make-location (buffer position)))                        (:constructor make-location (buffer position)))
# Line 1133  from an element and TEST is used to comp Line 1134  from an element and TEST is used to comp
1134           (if errors           (if errors
1135               `(("Unresolved" . ,errors))))))))               `(("Unresolved" . ,errors))))))))
1136    
1137    
1138    ;;;; Inspecting
1139    
1140    (defvar *inspectee*)
1141    (defvar *inspectee-parts*)
1142    (defvar *inspector-stack* '())
1143    (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
1144    (defvar *inspect-length* 30)
1145    
1146    (defun reset-inspector ()
1147      (setq *inspectee* nil)
1148      (setq *inspectee-parts* nil)
1149      (setq *inspector-stack* nil)
1150      (setf (fill-pointer *inspector-history*) 0))
1151    
1152    (defslimefun init-inspector (string)
1153      (reset-inspector)
1154      (inspect-object (eval (from-string string))))
1155    
1156    (defun print-part-to-string (value)
1157      (let ((*print-pretty* nil))
1158        (let ((string (to-string value))
1159              (pos (position value *inspector-history*)))
1160          (if pos
1161              (format nil "#~D=~A" pos string)
1162              string))))
1163    
1164    (defun inspect-object (object)
1165      (push (setq *inspectee* object) *inspector-stack*)
1166      (unless (find object *inspector-history*)
1167        (vector-push-extend object *inspector-history*))
1168      (multiple-value-bind (text parts) (inspected-parts object)
1169        (setq *inspectee-parts* parts)
1170        (list :text text
1171              :type (to-string (type-of object))
1172              :primitive-type (describe-primitive-type object)
1173              :parts (loop for (label . value) in parts
1174                           collect (cons label
1175                                         (print-part-to-string value))))))
1176    
1177    (defun nth-part (index)
1178      (cdr (nth index *inspectee-parts*)))
1179    
1180    (defslimefun inspect-nth-part (index)
1181      (inspect-object (nth-part index)))
1182    
1183    (defslimefun inspector-pop ()
1184      "Drop the inspector stack and inspect the second element.  Return
1185    nil if there's no second element."
1186      (cond ((cdr *inspector-stack*)
1187             (pop *inspector-stack*)
1188             (inspect-object (pop *inspector-stack*)))
1189            (t nil)))
1190    
1191    (defslimefun inspector-next ()
1192      "Inspect the next element in the *inspector-history*."
1193      (let ((position (position *inspectee* *inspector-history*)))
1194        (cond ((= (1+ position) (length *inspector-history*))
1195               nil)
1196              (t (inspect-object (aref *inspector-history* (1+ position)))))))
1197    
1198    (defslimefun quit-inspector ()
1199      (reset-inspector)
1200      nil)
1201    
1202    (defslimefun describe-inspectee ()
1203      "Describe the currently inspected object."
1204      (print-description-to-string *inspectee*))
1205    
1206    (defmethod inspected-parts ((object cons))
1207      (if (consp (cdr object))
1208          (inspected-parts-of-nontrivial-list object)
1209          (inspected-parts-of-simple-cons object)))
1210    
1211    (defun inspected-parts-of-simple-cons (object)
1212      (values "The object is a CONS."
1213              (list (cons (string 'car) (car object))
1214                    (cons (string 'cdr) (cdr object)))))
1215    
1216    (defun inspected-parts-of-nontrivial-list (object)
1217      (let ((length 0)
1218            (in-list object)
1219            (reversed-elements nil))
1220        (flet ((done (description-format)
1221                 (return-from inspected-parts-of-nontrivial-list
1222                   (values (format nil description-format length)
1223                           (nreverse reversed-elements)))))
1224          (loop
1225           (cond ((null in-list)
1226                  (done "The object is a proper list of length ~S.~%"))
1227                 ((>= length *inspect-length*)
1228                  (push (cons  (string 'rest) in-list) reversed-elements)
1229                  (done "The object is a long list (more than ~S elements).~%"))
1230                 ((consp in-list)
1231                  (push (cons (format nil "~D" length) (pop in-list))
1232                        reversed-elements)
1233                  (incf length))
1234                 (t
1235                  (push (cons (string 'rest) in-list) reversed-elements)
1236                  (done "The object is an improper list of length ~S.~%")))))))
1237    
1238  ;;; Local Variables:  ;;; Local Variables:
1239  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))

Legend:
Removed from v.1.101  
changed lines
  Added in v.1.102

  ViewVC Help
Powered by ViewVC 1.1.5