Commit 984032b3 authored by Helmut Eller's avatar Helmut Eller

Even more long line breaking.

parent 65e073ce
...@@ -7,6 +7,19 @@ ...@@ -7,6 +7,19 @@
* ChangeLog: * ChangeLog:
* swank-cmucl.lisp: * swank-cmucl.lisp:
* swank-lispworks.lisp: * swank-lispworks.lisp:
* contrib/ChangeLog
* hyperspec.el
* metering.lisp
* swank-abcl.lisp
* swank-allegro.lisp
* swank-backend.lisp
* swank-clisp.lisp
* swank-corman.lisp
* swank-ecl.lisp
* swank-sbcl.lisp
* swank-scl.lisp
* swank-source-path-parser.lisp
* xref.lisp
2012-04-06 Stas Boukarev <stassats@gmail.com> 2012-04-06 Stas Boukarev <stassats@gmail.com>
......
This diff is collapsed.
...@@ -100,7 +100,8 @@ If you copy the HyperSpec to another location, customize the variable ...@@ -100,7 +100,8 @@ If you copy the HyperSpec to another location, customize the variable
t stripped-symbol t stripped-symbol
'common-lisp-hyperspec-history))))) 'common-lisp-hyperspec-history)))))
(maplist (lambda (entry) (maplist (lambda (entry)
(browse-url (concat common-lisp-hyperspec-root "Body/" (car entry))) (browse-url (concat common-lisp-hyperspec-root "Body/"
(car entry)))
(if (cdr entry) (if (cdr entry)
(sleep-for 1.5))) (sleep-for 1.5)))
(let ((symbol (intern-soft (let ((symbol (intern-soft
...@@ -140,7 +141,8 @@ If you copy the HyperSpec to another location, customize the variable ...@@ -140,7 +141,8 @@ If you copy the HyperSpec to another location, customize the variable
;;; 20020213 Edi Weitz ;;; 20020213 Edi Weitz
(if common-lisp-hyperspec-symbol-table (if common-lisp-hyperspec-symbol-table
(let ((index-buffer (find-file-noselect common-lisp-hyperspec-symbol-table))) (let ((index-buffer (find-file-noselect
common-lisp-hyperspec-symbol-table)))
(labels ((get-one-line () (labels ((get-one-line ()
(prog1 (prog1
(delete* ?\n (thing-at-point 'line)) (delete* ?\n (thing-at-point 'line))
...@@ -153,7 +155,8 @@ If you copy the HyperSpec to another location, customize the variable ...@@ -153,7 +155,8 @@ If you copy the HyperSpec to another location, customize the variable
(relative-url (get-one-line))) (relative-url (get-one-line)))
(intern-clhs-symbol symbol-name (intern-clhs-symbol symbol-name
(subseq relative-url (subseq relative-url
(1+ (position ?\/ relative-url :from-end t))))))))) (1+ (position ?\/ relative-url
:from-end t)))))))))
(mapc (lambda (entry) (intern-clhs-symbol (car entry) (cadr entry))) (mapc (lambda (entry) (intern-clhs-symbol (car entry) (cadr entry)))
'(("&allow-other-keys" "03_da.htm") '(("&allow-other-keys" "03_da.htm")
("&aux" "03_da.htm") ("&aux" "03_da.htm")
...@@ -1247,8 +1250,9 @@ If you copy the HyperSpec to another location, customize the variable ...@@ -1247,8 +1250,9 @@ If you copy the HyperSpec to another location, customize the variable
nil nil 'common-lisp-hyperspec-format-history))))) nil nil 'common-lisp-hyperspec-format-history)))))
(maplist (lambda (entry) (maplist (lambda (entry)
(browse-url (common-lisp-hyperspec-section (car entry)))) (browse-url (common-lisp-hyperspec-section (car entry))))
(let ((symbol (intern-soft character-name (let ((symbol (intern-soft
common-lisp-hyperspec-format-characters))) character-name
common-lisp-hyperspec-format-characters)))
(if (and symbol (boundp symbol)) (if (and symbol (boundp symbol))
(symbol-value symbol) (symbol-value symbol)
(error "The symbol `%s' is not defined in Common Lisp" (error "The symbol `%s' is not defined in Common Lisp"
...@@ -1347,7 +1351,8 @@ cross-references table which is usually \"Map_IssX.txt\" or ...@@ -1347,7 +1351,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
(defvar common-lisp-hyperspec-issuex-symbols (make-vector 67 0)) (defvar common-lisp-hyperspec-issuex-symbols (make-vector 67 0))
(if common-lisp-hyperspec-issuex-table (if common-lisp-hyperspec-issuex-table
(let ((index-buffer (find-file-noselect common-lisp-hyperspec-issuex-table))) (let ((index-buffer (find-file-noselect
common-lisp-hyperspec-issuex-table)))
(labels ((get-one-line () (labels ((get-one-line ()
(prog1 (prog1
(delete* ?\n (thing-at-point 'line)) (delete* ?\n (thing-at-point 'line))
...@@ -1360,7 +1365,8 @@ cross-references table which is usually \"Map_IssX.txt\" or ...@@ -1360,7 +1365,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
common-lisp-hyperspec-issuex-symbols)) common-lisp-hyperspec-issuex-symbols))
(relative-url (get-one-line))) (relative-url (get-one-line)))
(set symbol (subseq relative-url (set symbol (subseq relative-url
(1+ (position ?\/ relative-url :from-end t))))))))) (1+ (position ?\/ relative-url
:from-end t)))))))))
(mapcar (mapcar
(lambda (entry) (lambda (entry)
(let ((symbol (intern (car entry) common-lisp-hyperspec-issuex-symbols))) (let ((symbol (intern (car entry) common-lisp-hyperspec-issuex-symbols)))
...@@ -1466,7 +1472,8 @@ cross-references table which is usually \"Map_IssX.txt\" or ...@@ -1466,7 +1472,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
("defconstant-special:no" "iss099.htm") ("defconstant-special:no" "iss099.htm")
("defgeneric-declare:allow-multiple" "iss100.htm") ("defgeneric-declare:allow-multiple" "iss100.htm")
("define-compiler-macro:x3j13-nov89" "iss101.htm") ("define-compiler-macro:x3j13-nov89" "iss101.htm")
("define-condition-syntax:incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm") ("define-condition-syntax:\
incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm")
("define-method-combination-behavior:clarify" "iss103.htm") ("define-method-combination-behavior:clarify" "iss103.htm")
("defining-macros-non-top-level:allow" "iss104.htm") ("defining-macros-non-top-level:allow" "iss104.htm")
("defmacro-block-scope:excludes-bindings" "iss105.htm") ("defmacro-block-scope:excludes-bindings" "iss105.htm")
...@@ -1637,7 +1644,8 @@ cross-references table which is usually \"Map_IssX.txt\" or ...@@ -1637,7 +1644,8 @@ cross-references table which is usually \"Map_IssX.txt\" or
("pretty-print-interface" "iss270.htm") ("pretty-print-interface" "iss270.htm")
("princ-readably:x3j13-dec-91" "iss271.htm") ("princ-readably:x3j13-dec-91" "iss271.htm")
("print-case-behavior:clarify" "iss272.htm") ("print-case-behavior:clarify" "iss272.htm")
("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" "iss273.htm") ("print-case-print-escape-interaction:vertical-bar-rule-no-upcase"
"iss273.htm")
("print-circle-shared:respect-print-circle" "iss274.htm") ("print-circle-shared:respect-print-circle" "iss274.htm")
("print-circle-structure:user-functions-work" "iss275.htm") ("print-circle-structure:user-functions-work" "iss275.htm")
("print-readably-behavior:clarify" "iss276.htm") ("print-readably-behavior:clarify" "iss276.htm")
......
...@@ -61,6 +61,7 @@ ...@@ -61,6 +61,7 @@
;;; Purely to cut down on stale code (e.g. #+cltl2) in this ;;; Purely to cut down on stale code (e.g. #+cltl2) in this
;;; version that is bundled with SLIME. ;;; version that is bundled with SLIME.
;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. ;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL.
;;; 07-Aug-12 heller Break lines at 80 columns
;;; ;;;
;;; ******************************** ;;; ********************************
...@@ -447,27 +448,6 @@ Estimated total monitoring overhead: 0.88 seconds ...@@ -447,27 +448,6 @@ Estimated total monitoring overhead: 0.88 seconds
;;; two lines with the commented out code. ;;; two lines with the commented out code.
#+openmcl #+openmcl
(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
;; #+openmcl
;; (progn
;; (in-package :ccl)
;; (defvar *bytes-consed-chkpt* 0)
;; (defun reset-consing () (setq *bytes-consed-chkpt* 0))
;; (let ((old-gc (symbol-function 'gc))
;; (ccl:*warn-if-redefine-kernel* nil))
;; (setf (symbol-function 'gc)
;; #'(lambda ()
;; (let ((old-consing (total-bytes-consed)))
;; (prog1
;; (funcall old-gc)
;; (incf *bytes-consed-chkpt*
;; (- old-consing (total-bytes-consed))))))))
;; (defun total-bytes-consed ()
;; "Returns number of conses (8 bytes each)"
;; (ccl::total-bytes-allocated))
;; (in-package "MONITOR")
;; (defun get-cons ()
;; (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*))))
#-(or clisp openmcl) #-(or clisp openmcl)
(progn (progn
...@@ -520,11 +500,13 @@ Estimated total monitoring overhead: 0.88 seconds ...@@ -520,11 +500,13 @@ Estimated total monitoring overhead: 0.88 seconds
(beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
(re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
`(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time) ,gc1 ,gc2 ,beg-cons1 ,beg-cons2)
(sys::%%time)
(declare (ignore ,re1 ,re2 ,gc1 ,gc2)) (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
(multiple-value-prog1 ,form (multiple-value-prog1 ,form
(multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time) ,gc1 ,gc2 ,end-cons1 ,end-cons2)
(sys::%%time)
(declare (ignore ,re1 ,re2 ,gc1 ,gc2)) (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
(let ((,delta-time (delta4-time ,end-time1 ,end-time2 (let ((,delta-time (delta4-time ,end-time1 ,end-time2
,beg-time1 ,beg-time2)) ,beg-time1 ,beg-time2))
...@@ -572,7 +554,8 @@ Estimated total monitoring overhead: 0.88 seconds ...@@ -572,7 +554,8 @@ Estimated total monitoring overhead: 0.88 seconds
(progn (progn
(eval-when (compile eval) (eval-when (compile eval)
(warn (warn
"You may want to add an implementation-specific Required-Arguments function.")) "You may want to add an implementation-specific ~
Required-Arguments function."))
(eval-when (load eval) (eval-when (load eval)
(defun required-arguments (name) (defun required-arguments (name)
(declare (ignore name)) (declare (ignore name))
...@@ -1123,8 +1106,9 @@ functions set NAMES to be either NIL or :ALL." ...@@ -1123,8 +1106,9 @@ functions set NAMES to be either NIL or :ALL."
*monitor-results*)))) *monitor-results*))))
(display-monitoring-results threshold key ignore-no-calls))))) (display-monitoring-results threshold key ignore-no-calls)))))
(defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time) (defun display-monitoring-results (&optional (threshold 0.01)
(ignore-no-calls t)) (key :percent-time)
(ignore-no-calls t))
(let ((max-length 8) ; Function header size (let ((max-length 8) ; Function header size
(max-cons-length 8) (max-cons-length 8)
(total-time 0.0) (total-time 0.0)
...@@ -1147,8 +1131,10 @@ functions set NAMES to be either NIL or :ALL." ...@@ -1147,8 +1131,10 @@ functions set NAMES to be either NIL or :ALL."
(format *trace-output* (format *trace-output*
"~%~%~ "~%~%~
~VT ~VA~ ~VT ~VA~
~% ~VT % % ~VA Total Total~ ~% ~VT % % ~VA ~
~%Function~VT Time Cons Calls Sec/Call ~VA Time Cons~ Total Total~
~%Function~VT Time Cons Calls Sec/Call ~VA ~
Time Cons~
~%~V,,,'-A" ~%~V,,,'-A"
max-length max-length
max-cons-length "Cons" max-cons-length "Cons"
......
...@@ -80,7 +80,8 @@ ...@@ -80,7 +80,8 @@
standard-slot-definition ;;dummy standard-slot-definition ;;dummy
cl:method cl:method
cl:standard-class cl:standard-class
#+#.(swank-backend:with-symbol 'compute-applicable-methods-using-classes 'mop) #+#.(swank-backend:with-symbol 'compute-applicable-methods-using-classes
'mop)
mop::compute-applicable-methods-using-classes mop::compute-applicable-methods-using-classes
;; standard-class readers ;; standard-class readers
mop::class-default-initargs mop::class-default-initargs
...@@ -191,7 +192,8 @@ ...@@ -191,7 +192,8 @@
(defvar *external-format-to-coding-system* (defvar *external-format-to-coding-system*
'((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
((:iso-8859-1 :eol-style :lf) "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") ((:iso-8859-1 :eol-style :lf)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
(:utf-8 "utf-8") (:utf-8 "utf-8")
((:utf-8 :eol-style :lf) "utf-8-unix") ((:utf-8 :eol-style :lf) "utf-8-unix")
(:euc-jp "euc-jp") (:euc-jp "euc-jp")
...@@ -256,7 +258,8 @@ ...@@ -256,7 +258,8 @@
(sys::arglist fun) (sys::arglist fun)
(when (and (not present) (when (and (not present)
(fboundp fun) (fboundp fun)
(typep (symbol-function fun) 'standard-generic-function)) (typep (symbol-function fun)
'standard-generic-function))
(setq arglist (setq arglist
(mop::generic-function-lambda-list (symbol-function fun)) (mop::generic-function-lambda-list (symbol-function fun))
present present
...@@ -629,22 +632,25 @@ part of *sysdep-pathnames* in swank.loader.lisp. ...@@ -629,22 +632,25 @@ part of *sysdep-pathnames* in swank.loader.lisp.
,@(if parts ,@(if parts
(loop :for (label . value) :in parts (loop :for (label . value) :in parts
:appending (label-value-line label value)) :appending (label-value-line label value))
(list "No inspectable parts, dumping output of CL:DESCRIBE:" '(:newline) (list "No inspectable parts, dumping output of CL:DESCRIBE:"
'(:newline)
(with-output-to-string (desc) (describe o desc))))))) (with-output-to-string (desc) (describe o desc)))))))
(defmethod emacs-inspect ((slot mop::slot-definition)) (defmethod emacs-inspect ((slot mop::slot-definition))
`("Name: " (:value ,(mop::%slot-definition-name slot)) `("Name: "
(:newline) (:value ,(mop::%slot-definition-name slot))
"Documentation:" (:newline) (:newline)
,@(when (slot-definition-documentation slot) "Documentation:" (:newline)
`((:value ,(slot-definition-documentation slot)) (:newline))) ,@(when (slot-definition-documentation slot)
"Initialization:" (:newline) `((:value ,(slot-definition-documentation slot)) (:newline)))
" Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline) "Initialization:" (:newline)
" Form: " ,(if (mop::%slot-definition-initfunction slot) " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
`(:value ,(mop::%slot-definition-initform slot)) " Form: " ,(if (mop::%slot-definition-initfunction slot)
"#<unspecified>") (:newline) `(:value ,(mop::%slot-definition-initform slot))
" Function: " (:value ,(mop::%slot-definition-initfunction slot)) "#<unspecified>") (:newline)
(:newline))) " Function: "
(:value ,(mop::%slot-definition-initfunction slot))
(:newline)))
(defmethod emacs-inspect ((f function)) (defmethod emacs-inspect ((f function))
`(,@(when (function-name f) `(,@(when (function-name f)
...@@ -652,10 +658,13 @@ part of *sysdep-pathnames* in swank.loader.lisp. ...@@ -652,10 +658,13 @@ part of *sysdep-pathnames* in swank.loader.lisp.
,(princ-to-string (function-name f)) (:newline))) ,(princ-to-string (function-name f)) (:newline)))
,@(multiple-value-bind (args present) ,@(multiple-value-bind (args present)
(sys::arglist f) (sys::arglist f)
(when present `("Argument list: " ,(princ-to-string args) (:newline)))) (when present
`("Argument list: "
,(princ-to-string args) (:newline))))
(:newline) (:newline)
#+nil,@(when (documentation f t) #+nil,@(when (documentation f t)
`("Documentation:" (:newline) ,(documentation f t) (:newline))) `("Documentation:" (:newline)
,(documentation f t) (:newline)))
,@(when (function-lambda-expression f) ,@(when (function-lambda-expression f)
`("Lambda expression:" `("Lambda expression:"
(:newline) ,(princ-to-string (:newline) ,(princ-to-string
...@@ -666,20 +675,21 @@ part of *sysdep-pathnames* in swank.loader.lisp. ...@@ -666,20 +675,21 @@ part of *sysdep-pathnames* in swank.loader.lisp.
;;; case, so make its computation a user interaction. ;;; case, so make its computation a user interaction.
(defparameter *to-string-hashtable* (make-hash-table)) (defparameter *to-string-hashtable* (make-hash-table))
(defmethod emacs-inspect ((o java:java-object)) (defmethod emacs-inspect ((o java:java-object))
(let ((to-string (lambda () (let ((to-string (lambda ()
(handler-case (handler-case
(setf (gethash o *to-string-hashtable*) (setf (gethash o *to-string-hashtable*)
(java:jcall "toString" o)) (java:jcall "toString" o))
(t (e) (t (e)
(setf (gethash o *to-string-hashtable*) (setf (gethash o *to-string-hashtable*)
(format nil "Could not invoke toString(): ~A" (format nil
e))))))) "Could not invoke toString(): ~A"
(append e)))))))
(if (gethash o *to-string-hashtable*) (append
(label-value-line "toString()" (gethash o *to-string-hashtable*)) (if (gethash o *to-string-hashtable*)
`((:action "[compute toString()]" ,to-string) (:newline))) (label-value-line "toString()" (gethash o *to-string-hashtable*))
(loop :for (label . value) :in (sys:inspected-parts o) `((:action "[compute toString()]" ,to-string) (:newline)))
:appending (label-value-line label value))))) (loop :for (label . value) :in (sys:inspected-parts o)
:appending (label-value-line label value)))))
;;;; Multithreading ;;;; Multithreading
......
...@@ -223,7 +223,8 @@ ...@@ -223,7 +223,8 @@
(car (debugger:frame-expression frame)))))))))) (car (debugger:frame-expression frame))))))))))
(defun function-source-location (fun) (defun function-source-location (fun)
(cadr (car (fspec-definition-locations (xref::object-to-function-name fun))))) (cadr (car (fspec-definition-locations
(xref::object-to-function-name fun)))))
#+(version>= 8 2) #+(version>= 8 2)
(defun pc-source-location (fun pc) (defun pc-source-location (fun pc)
...@@ -533,7 +534,8 @@ ...@@ -533,7 +534,8 @@
(t (t
(find-definition-in-file fspec type file top-level))))) (find-definition-in-file fspec type file top-level)))))
((member :top-level) ((member :top-level)
(make-error-location "Defined at toplevel: ~A" (fspec->string fspec)))) (make-error-location "Defined at toplevel: ~A"
(fspec->string fspec))))
(error (e) (error (e)
(make-error-location "Error: ~A" e)))) (make-error-location "Error: ~A" e))))
...@@ -646,7 +648,8 @@ ...@@ -646,7 +648,8 @@
;;;; Profiling ;;;; Profiling
;; Per-function profiling based on description in ;; Per-function profiling based on description in
;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data-collection-control-2 ;; http://www.franz.com/support/documentation/8.0/\
;; doc/runtime-analyzer.htm#data-collection-control-2
(defvar *profiled-functions* ()) (defvar *profiled-functions* ())
(defvar *profile-depth* 0) (defvar *profile-depth* 0)
......
...@@ -160,7 +160,6 @@ Backends implement these functions using DEFIMPLEMENTATION." ...@@ -160,7 +160,6 @@ Backends implement these functions using DEFIMPLEMENTATION."
,(if (null default-body) ,(if (null default-body)
`(pushnew ',name *unimplemented-interfaces*) `(pushnew ',name *unimplemented-interfaces*)
(gen-default-impl)) (gen-default-impl))
;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(export ',name :swank-backend)) (export ',name :swank-backend))
',name))) ',name)))
...@@ -755,10 +754,12 @@ additional information on the specifiers defined in ANSI Common Lisp.") ...@@ -755,10 +754,12 @@ additional information on the specifiers defined in ANSI Common Lisp.")
(type '(type-specifier &rest args)) (type '(type-specifier &rest args))
(ftype '(type-specifier &rest function-names)) (ftype '(type-specifier &rest function-names))
(otherwise (otherwise
(flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol)))) (flet ((typespec-p (symbol)
(member :type (describe-symbol-for-emacs symbol))))
(cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
'(&rest variables)) '(&rest variables))
((and (listp decl-identifier) (typespec-p (first decl-identifier))) ((and (listp decl-identifier)
(typespec-p (first decl-identifier)))
'(&rest variables)) '(&rest variables))
(t :not-available))))))) (t :not-available)))))))
...@@ -781,7 +782,8 @@ additional information on the specifiers defined in ANSI Common Lisp.") ...@@ -781,7 +782,8 @@ additional information on the specifiers defined in ANSI Common Lisp.")
(definterface function-name (function) (definterface function-name (function)
"Return the name of the function object FUNCTION. "Return the name of the function object FUNCTION.
The result is either a symbol, a list, or NIL if no function name is available." The result is either a symbol, a list, or NIL if no function name is
available."
(declare (ignore function)) (declare (ignore function))
nil) nil)
...@@ -1066,7 +1068,8 @@ returns.") ...@@ -1066,7 +1068,8 @@ returns.")
(cond ((typep datum 'condition) (cond ((typep datum 'condition)
`(:error ,(format nil "Error: ~A" datum))) `(:error ,(format nil "Error: ~A" datum)))
((symbolp datum) ((symbolp datum)
`(:error ,(format nil "Error: ~A" (apply #'make-condition datum args)))) `(:error ,(format nil "Error: ~A"
(apply #'make-condition datum args))))
(t (t
(assert (stringp datum)) (assert (stringp datum))
`(:error ,(apply #'format nil datum args))))) `(:error ,(apply #'format nil datum args)))))
......
...@@ -330,20 +330,24 @@ Return NIL if the symbol is unbound." ...@@ -330,20 +330,24 @@ Return NIL if the symbol is unbound."
(fspec-pathname fspec) (fspec-pathname fspec)
(list (if type (list name type) name) (list (if type (list name type) name)
(cond (file (cond (file
(multiple-value-bind (truename c) (ignore-errors (truename file)) (multiple-value-bind (truename c)
(ignore-errors (truename file))
(cond (truename (cond (truename
(make-location (list :file (namestring truename)) (make-location
(if (consp lines) (list :file (namestring truename))
(list* :line lines) (if (consp lines)
(list :function-name (string name))) (list* :line lines)
(when (consp type) (list :function-name (string name)))
(list :snippet (format nil "~A" type))))) (when (consp type)
(list :snippet (format nil "~A" type)))))
(t (list :error (princ-to-string c)))))) (t (list :error (princ-to-string c))))))
(t (list :error (format nil "No source information available for: ~S" (t (list :error
fspec))))))) (format nil "No source information available for: ~S"
fspec)))))))
(defimplementation find-definitions (name) (defimplementation find-definitions (name)
(mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file))) (mapcar #'(lambda (e) (fspec-location name e))
(documentation name 'sys::file)))
(defun trim-whitespace (string) (defun trim-whitespace (string)
(string-trim #(#\newline #\space #\tab) string)) (string-trim #(#\newline #\space #\tab) string))
......
...@@ -78,7 +78,8 @@ ...@@ -78,7 +78,8 @@
(defclass swank-mop:standard-slot-definition () (defclass swank-mop:standard-slot-definition ()
() ()
(:documentation "Dummy class created so that swank.lisp will compile and load.")) (:documentation
"Dummy class created so that swank.lisp will compile and load."))
(defun named-by-gensym-p (c) (defun named-by-gensym-p (c)
(null (symbol-package (class-name c)))) (null (symbol-package (class-name c))))
...@@ -168,10 +169,12 @@ ...@@ -168,10 +169,12 @@
(make-frame :function nil) (make-frame :function nil)
(loop for i from db::*debug-min-level* (loop for i from db::*debug-min-level*
upto db::*debug-max-level* upto db::*debug-max-level*
until (eq (db::get-frame-function i) cl::*top-level*) until (eq (db::get-frame-function i)
cl::*top-level*)
collect collect
(make-frame :function (db::get-frame-function i) (make-frame
:address (db::get-frame-address i)))) :function (db::get-frame-function i)
:address (db::get-frame-address i))))
:key #'frame-function))))) :key #'frame-function)))))
(funcall fn))) (funcall fn)))
...@@ -280,8 +283,9 @@ ...@@ -280,8 +283,9 @@
(if (ccl::function-source-line fspec) (if (ccl::function-source-line fspec)
(list :line (list :line
(1+ (ccl::function-source-line fspec))) (1+ (ccl::function-source-line fspec)))
(list :function-name (princ-to-string (list :function-name
(function-name fspec)))))) (princ-to-string
(function-name fspec))))))
(error (c) (list :error (princ-to-string c)))) (error (c) (list :error (princ-to-string c))))
(list :error (format nil "No source information available for ~S" (list :error (format nil "No source information available for ~S"
fspec))))) fspec)))))
...@@ -396,56 +400,67 @@ ...@@ -396,56 +400,67 @@
collect ", "))) collect ", ")))
(defmethod emacs-inspect ((class standard-class)) (defmethod emacs-inspect ((class standard-class))
`("Name: " (:value ,(class-name class)) `("Name: "
(:newline) (:value ,(class-name class))
"Super classes: " (:newline)
,@(comma-separated (swank-mop:class-direct-superclasses class)) "Super classes: "
(:newline) ,@(comma-separated (swank-mop:class-direct-superclasses class))
"Direct Slots: " (:newline)
,@(comma-separated "Direct Slots: "
(swank-mop:class-direct-slots class) ,@(comma-separated
(lambda (slot) (swank-mop:class-direct-slots class)
`(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot))))) (lambda (slot)
(:newline) `(:value ,slot
"Effective Slots: " ,(princ-to-string
,@(if (swank-mop:class-finalized-p class) (swank-mop:slot-definition-name slot)))))
(comma-separated (:newline)
(swank-mop:class-slots class) "Effective Slots: "
(lambda (slot) ,@(if (swank-mop:class-finalized-p class)
`(:value ,slot ,(princ-to-string (comma-separated
(swank-mop:slot-definition-name slot))))) (swank-mop:class-slots class)
'("#<N/A (class not finalized)>")) (lambda (slot)
(:newline) `(:value ,slot ,(princ-to-string
,@(when (documentation class t) (swank-mop:slot-definition-name slot)))))
`("Documentation:" (:newline) ,(documentation class t) (:newline))) '("#<N/A (class not finalized)>"))
"Sub classes: " (:newline)
,@(comma-separated (swank-mop:class-direct-subclasses class) ,@(when (documentation class t)
(lambda (sub) `("Documentation:" (:newline) ,(documentation class t) (:newline)))
`(:value ,sub ,(princ-to-string (class-name sub))))) "Sub classes: "
(:newline) ,@(comma-separated (swank-mop:class-direct-subclasses class)
"Precedence List: " (lambda (sub)
,@(if (swank-mop:class-finalized-p class) `(:value ,sub ,(princ-to-string (class-name sub)))))
(comma-separated (swank-mop:class-precedence-list class) (:newline)
(lambda (class) "Precedence List: "
`(:value ,class ,(princ-to-string (class-name class))))) ,@(if (swank-mop:class-finalized-p class)
'("#<N/A (class not finalized)>")) (comma-separated
(:newline))) (swank-mop:class-precedence-list class)
(lambda (class)
`(:value ,class
,(princ-to-string (class-name class)))))
'("#<N/A (class not finalized)>"))
(:newline)))
(defmethod emacs-inspect ((slot cons)) (defmethod emacs-inspect ((slot cons))
;; Inspects slot definitions ;; Inspects slot definitions
(if (eq (car slot) :name) (if (eq (car slot) :name)
`("Name: " (:value ,(swank-mop:slot-definition-name slot)) `("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline) (:newline)
,@(when (swank-mop:slot-definition-documentation slot) ,@(when (swank-mop:slot-definition-documentation slot)
`("Documentation:" (:newline) `("Documentation:"
(:value ,(swank-mop:slot-definition-documentation slot)) (:newline)
(:newline))) (:value
"Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) ,(swank-mop:slot-definition-documentation slot))
"Init form: " ,(if (swank-mop:slot-definition-initfunction slot) (:newline)))
`(:value ,(swank-mop:slot-definition-initform slot)) "Init args: " (:value
"#<unspecified>") (:newline) ,(swank-mop:slot-definition-initargs slot))
"Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline)
(:newline)) "Init form: "
,(if (swank-mop:slot-definition-initfunction slot)
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: "
(:value ,(swank-mop:slot-definition-initfunction slot))
(:newline))
(call-next-method))) (call-next-method)))
(defmethod emacs-inspect ((pathname pathnames::pathname-internal)) (defmethod emacs-inspect ((pathname pathnames::pathname-internal))
......
...@@ -476,7 +476,8 @@ ...@@ -476,7 +476,8 @@
(third (elt *backtrace* frame-number))) (third (elt *backtrace* frame-number)))
(defimplementation frame-locals (frame-number) (defimplementation frame-locals (frame-number)
(loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) (loop for (name . value) in (nth-value 2 (frame-decode-env
(elt *backtrace* frame-number)))
with i = 0 with i = 0
collect (list :name name :id (prog1 i (incf i)) :value value))) collect (list :name name :id (prog1 i (incf i)) :value value)))