From heller at common-lisp.net Mon Mar 1 08:59:08 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Mar 2004 03:59:08 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17715 Modified Files: swank-lispworks.lisp Log Message: (dspec-buffer-position): Handle defgeneric. (replace-source-file, patch-source-locations): New function. (compile-string-for-emacs): Patch the recorded source locations. (make-dspec-location): Handle (patched) emacs-buffer locations. (emacs-buffer-location-p): New function. (describe-primitive-type, inspected-parts): Implemented. (kill-thread): Implemented. Date: Mon Mar 1 03:59:08 2004 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.24 slime/swank-lispworks.lisp:1.25 --- slime/swank-lispworks.lisp:1.24 Thu Feb 26 02:12:02 2004 +++ slime/swank-lispworks.lisp Mon Mar 1 03:59:08 2004 @@ -302,15 +302,20 @@ (delete-file binary-filename)))) (delete-file filename))) +;; XXX handle all cases in dspec:*dspec-classes* (defun dspec-buffer-position (dspec) (etypecase dspec (cons (ecase (car dspec) - ((defun method defmacro) + ((defun method defmacro defgeneric) `(:function-name ,(symbol-name (cadr dspec)))) ;; XXX this isn't quite right (lw:top-level-form `(:source-path ,(cdr dspec) nil)))) (symbol `(:function-name ,(symbol-name dspec))))) +(defun emacs-buffer-location-p (location) + (and (consp location) + (eq (car location) :emacs-buffer))) + (defun make-dspec-location (dspec location &optional tmpfile buffer position) (flet ((from-buffer-p () (and (pathnamep location) tmpfile @@ -336,7 +341,12 @@ ((member :listener) `(:error ,(format nil "Function defined in listener: ~S" dspec))) ((member :unknown) - `(:error ,(format nil "Function location unkown: ~S" dspec)))) + `(:error ,(format nil "Function location unkown: ~S" dspec))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset) location + (declare (ignore _ offset)) + (make-location `(:buffer ,buffer) + (dspec-buffer-position dspec))))) )))) (defun signal-error-data-base (database &optional tmpfile buffer position) @@ -358,6 +368,25 @@ nil))) htab)) +(defun replace-source-file (info tmpfile buffer position) + (dolist (cons info) + (destructuring-bind (dspec . location) cons + (etypecase dspec + (cons (when (and (or (stringp location) + (pathnamep location)) + (pathname-match-p location tmpfile)) + (setf (cdr cons) + (list :emacs-buffer buffer position)))) + (symbol + (dolist (info location) + (replace-source-file info tmpfile buffer position))))))) + +(defun patch-source-locations (tmpname buffer position) + (maphash (lambda (name info) + (declare (ignore name)) + (replace-source-file info tmpname buffer position)) + (dspec::dc-database (dspec::find-dc 'function)))) + (defimplementation compile-string-for-emacs (string &key buffer position) (assert buffer) (assert position) @@ -370,7 +399,8 @@ (signal-error-data-base compiler::*error-database* tmpname buffer position) (signal-undefined-functions compiler::*unknown-functions* - tmpname tmpname buffer position)))) + tmpname tmpname buffer position) + (patch-source-locations tmpname buffer position)))) ;;; xref @@ -404,6 +434,21 @@ (defimplementation list-callees (symbol-name) (lookup-xrefs #'hcl:calls-who symbol-name)) +;;; Inspector + +(defimplementation describe-primitive-type (object) + (declare (ignore object)) + "NYI") + +(defmethod inspected-parts (o) + (multiple-value-bind (names values _getter _setter type) + (lw:get-inspector-values o nil) + (declare (ignore _getter _setter)) + (values (format nil "~A~% is a ~A" o type) + (mapcar (lambda (name value) + (cons (princ-to-string name) value)) + names values)))) + ;;; Multithreading (defimplementation startup-multiprocessing () @@ -434,6 +479,9 @@ (defimplementation interrupt-thread (thread fn) (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) (defvar *mailbox-lock* (mp:make-lock)) From heller at common-lisp.net Mon Mar 1 09:02:06 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Mar 2004 04:02:06 -0500 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11863 Modified Files: swank-allegro.lisp Log Message: (kill-thread): Implemented. Date: Mon Mar 1 04:02:06 2004 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.15 slime/swank-allegro.lisp:1.16 --- slime/swank-allegro.lisp:1.15 Thu Feb 26 02:16:16 2004 +++ slime/swank-allegro.lisp Mon Mar 1 04:02:06 2004 @@ -345,6 +345,9 @@ (defimplementation interrupt-thread (thread fn) (mp:process-interrupt thread fn)) +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock")) (defstruct (mailbox (:conc-name mailbox.)) From heller at common-lisp.net Mon Mar 1 09:02:15 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Mar 2004 04:02:15 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12535 Modified Files: swank-cmucl.lisp Log Message: (kill-thread): Implemented. Date: Mon Mar 1 04:02:15 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.72 slime/swank-cmucl.lisp:1.73 --- slime/swank-cmucl.lisp:1.72 Wed Feb 25 17:03:39 2004 +++ slime/swank-cmucl.lisp Mon Mar 1 04:02:15 2004 @@ -1358,6 +1358,9 @@ (defimplementation interrupt-thread (thread fn) (mp:process-interrupt thread fn)) + (defimplementation kill-thread (thread) + (mp:destroy-process thread)) + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) (defstruct (mailbox (:conc-name mailbox.)) From heller at common-lisp.net Mon Mar 1 09:02:23 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Mar 2004 04:02:23 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13414 Modified Files: swank-sbcl.lisp Log Message: (kill-thread): Implemented. Date: Mon Mar 1 04:02:23 2004 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.69 slime/swank-sbcl.lisp:1.70 --- slime/swank-sbcl.lisp:1.69 Thu Feb 26 02:15:51 2004 +++ slime/swank-sbcl.lisp Mon Mar 1 04:02:23 2004 @@ -206,6 +206,7 @@ (defvar *buffer-name* nil) (defvar *buffer-offset*) +(defvar *buffer-substring* nil) (defvar *previous-compiler-condition* nil "Used to detect duplicates.") @@ -333,7 +334,8 @@ (with-compilation-hooks () (let ((*package* *buffer-package*) (*buffer-name* buffer) - (*buffer-offset* position)) + (*buffer-offset* position) + (*buffer-substring* string)) (eval (from-string (format nil "(funcall (compile nil '(lambda () ~A)))" string)))))) @@ -767,7 +769,10 @@ (defimplementation interrupt-thread (thread fn) (sb-thread:interrupt-thread thread fn)) - ;; XXX there is some deadlock / race condition here + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + ;; XXX there is some deadlock / race condition here (with old 2.4 kernels) (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) (defvar *mailboxes* (list)) @@ -806,7 +811,3 @@ mutex)))))))) ) - -;;; Local Variables: -;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) -;;; End: From heller at common-lisp.net Mon Mar 1 09:04:24 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 01 Mar 2004 04:04:24 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3136 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Mar 1 04:04:24 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.274 slime/ChangeLog:1.275 --- slime/ChangeLog:1.274 Sun Feb 29 04:07:07 2004 +++ slime/ChangeLog Mon Mar 1 04:04:24 2004 @@ -1,3 +1,17 @@ +2004-03-01 Helmut Eller + + * swank-lispworks.lisp (compile-string-for-emacs): Patch the + recorded source locations. + (replace-source-file, patch-source-locations): New function. + (dspec-buffer-position): Handle defgeneric. + (make-dspec-location): Handle (patched) emacs-buffer locations. + (emacs-buffer-location-p): New function. + (describe-primitive-type, inspected-parts): Implemented. + (kill-thread): Implemented. + + * swank-sbcl.lisp, swank-cmucl.lisp, swank-allegro.lisp + (kill-thread): Implemented. + 2004-02-29 Helmut Eller * slime.el (slime-complete-symbol): Make slime-complete-symbol From mbaringer at common-lisp.net Mon Mar 1 15:46:30 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Mon, 01 Mar 2004 10:46:30 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14913 Modified Files: ChangeLog swank.lisp Log Message: See ChangeLog entry Marco Baringer 2004-03-01 Date: Mon Mar 1 10:46:29 2004 Author: mbaringer Index: slime/ChangeLog diff -u slime/ChangeLog:1.275 slime/ChangeLog:1.276 --- slime/ChangeLog:1.275 Mon Mar 1 04:04:24 2004 +++ slime/ChangeLog Mon Mar 1 10:46:27 2004 @@ -1,3 +1,7 @@ +2004-03-01 Marco Baringer + + * swank.lisp (format-arglist): deal with nil arglists. + 2004-03-01 Helmut Eller * swank-lispworks.lisp (compile-string-for-emacs): Patch the Index: slime/swank.lisp diff -u slime/swank.lisp:1.130 slime/swank.lisp:1.131 --- slime/swank.lisp:1.130 Sun Feb 29 03:59:28 2004 +++ slime/swank.lisp Mon Mar 1 10:46:27 2004 @@ -696,10 +696,12 @@ (let ((symbol (find-symbol-or-lose function-name))) (values (funcall lambda-list-fn symbol)))) (cond (condition (format nil "(-- ~A)" condition)) - (t (let ((*print-case* :downcase) - (*print-level* nil) - (*print-length* nil)) - (princ-to-string arglist)))))) + (t (if (null arglist) + "()" + (let ((*print-case* :downcase) + (*print-level* nil) + (*print-length* nil)) + (princ-to-string arglist))))))) ;;;; Debugger From heller at common-lisp.net Wed Mar 3 07:08:34 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 02:08:34 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22832 Modified Files: swank-lispworks.lisp Log Message: (call-with-debugging-environment): Bind *sldb-top-frame*. (nth-frame): Use *sldb-top-frame*. (name-source-location, name-source-locations): Renamed from dspec-source-location, dspec-source-locations. The result now includes methods for generic functions. (eval-in-frame, return-from-frame, restart-frame): Implemented. (compile-string-for-emacs): Set dspec::*location* to the buffer location. (signal-undefined-functions, signal-error-data-base) (make-dspec-location): Remove temp-file kludges. (patch-source-locations, replace-source-file): Deleted. Date: Wed Mar 3 02:08:34 2004 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.25 slime/swank-lispworks.lisp:1.26 --- slime/swank-lispworks.lisp:1.25 Mon Mar 1 03:59:08 2004 +++ slime/swank-lispworks.lisp Wed Mar 3 02:08:33 2004 @@ -156,13 +156,16 @@ ;;; Debugging (defvar *sldb-restarts*) +(defvar *sldb-top-frame*) (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) (defimplementation call-with-debugging-environment (fn) (dbg::with-debugger-stack () - (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*))) + (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)) + (*sldb-top-frame* (dbg::debugger-stack-current-frame + dbg::*debugger-stack*))) (funcall fn)))) (defun format-restarts-for-emacs () @@ -176,8 +179,7 @@ )) (defun nth-frame (index) - (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*) - (dbg::frame-next frame)) + (do ((frame *sldb-top-frame* (dbg::frame-next frame)) (i index (if (interesting-frame-p frame) (1- i) i))) ((and (interesting-frame-p frame) (zerop i)) frame) (assert frame))) @@ -242,24 +244,38 @@ (if (dbg::call-frame-p frame) (let ((func (dbg::call-frame-function-name frame))) (if func - (dspec-source-location func)))))) + (name-source-location func)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defimplementation return-from-frame (frame-number form) + (let* ((frame (nth-frame frame-number)) + (return-frame (dbg::find-frame-for-return frame)) + (form (from-string form))) + (dbg::dbg-return-from-call-frame frame form return-frame + dbg::*debugger-stack*))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::restart-frame frame :same-args t))) ;;; Definition finding -(defun dspec-source-location (dspec) - (destructuring-bind (first) (dspec-source-locations dspec) - first)) +(defun name-source-location (name) + (first (name-source-locations name))) -(defun dspec-source-locations (dspec) - (let ((locations (dspec:find-dspec-locations dspec))) +(defun name-source-locations (name) + (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) (cond ((not locations) - (list :error (format nil "Cannot find source for ~S" dspec))) + (list :error (format nil "Cannot find source for ~S" name))) (t (loop for (dspec location) in locations collect (make-dspec-location dspec location)))))) (defimplementation find-function-locations (fname) - (dspec-source-locations (from-string fname))) + (name-source-locations (from-string fname))) ;;; Compilation @@ -267,7 +283,7 @@ (let ((compiler::*error-database* '())) (with-compilation-unit () (compile-file filename :load load-p) - (signal-error-data-base compiler::*error-database*) + (signal-error-data-base compiler::*error-database* filename) (signal-undefined-functions compiler::*unknown-functions* filename)))) (defun map-error-database (database fn) @@ -306,7 +322,8 @@ (defun dspec-buffer-position (dspec) (etypecase dspec (cons (ecase (car dspec) - ((defun method defmacro defgeneric) + ((defun defmacro defgeneric defvar defstruct + method structure package) `(:function-name ,(symbol-name (cadr dspec)))) ;; XXX this isn't quite right (lw:top-level-form `(:source-path ,(cdr dspec) nil)))) @@ -316,11 +333,8 @@ (and (consp location) (eq (car location) :emacs-buffer))) -(defun make-dspec-location (dspec location &optional tmpfile buffer position) - (flet ((from-buffer-p () - (and (pathnamep location) tmpfile - (pathname-match-p location tmpfile))) - (filename (pathname) +(defun make-dspec-location (dspec location) + (flet ((filename (pathname) (multiple-value-bind (truename condition) (ignore-errors (truename pathname)) (cond (condition @@ -331,76 +345,55 @@ (etypecase dspec (symbol (symbol-name dspec)) (cons (string (dspec:dspec-primary-name dspec)))))) - (cond ((from-buffer-p) - (make-location `(:buffer ,buffer) `(:position ,position))) - (t - (etypecase location - ((or pathname string) - (make-location `(:file ,(filename location)) - (dspec-buffer-position dspec))) - ((member :listener) - `(:error ,(format nil "Function defined in listener: ~S" dspec))) - ((member :unknown) - `(:error ,(format nil "Function location unkown: ~S" dspec))) - ((satisfies emacs-buffer-location-p) - (destructuring-bind (_ buffer offset) location - (declare (ignore _ offset)) - (make-location `(:buffer ,buffer) - (dspec-buffer-position dspec))))) - )))) + (etypecase location + ((or pathname string) + (make-location `(:file ,(filename location)) + (dspec-buffer-position dspec))) + ((member :listener) + `(:error ,(format nil "Function defined in listener: ~S" dspec))) + ((member :unknown) + `(:error ,(format nil "Function location unkown: ~S" dspec))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset string) location + (declare (ignore _ offset string)) + (make-location `(:buffer ,buffer) + (dspec-buffer-position dspec))))))) -(defun signal-error-data-base (database &optional tmpfile buffer position) +(defun signal-error-data-base (database location) (map-error-database database (lambda (filename dspec condition) + (declare (ignore filename)) (signal-compiler-condition (format nil "~A" condition) - (make-dspec-location dspec filename tmpfile buffer position) + (make-dspec-location dspec location) condition)))) -(defun signal-undefined-functions (htab filename - &optional tmpfile buffer position) +(defun signal-undefined-functions (htab filename) (maphash (lambda (unfun dspecs) (dolist (dspec dspecs) (signal-compiler-condition (format nil "Undefined function ~A" unfun) - (make-dspec-location dspec filename tmpfile buffer position) + (make-dspec-location dspec filename) nil))) htab)) -(defun replace-source-file (info tmpfile buffer position) - (dolist (cons info) - (destructuring-bind (dspec . location) cons - (etypecase dspec - (cons (when (and (or (stringp location) - (pathnamep location)) - (pathname-match-p location tmpfile)) - (setf (cdr cons) - (list :emacs-buffer buffer position)))) - (symbol - (dolist (info location) - (replace-source-file info tmpfile buffer position))))))) - -(defun patch-source-locations (tmpname buffer position) - (maphash (lambda (name info) - (declare (ignore name)) - (replace-source-file info tmpname buffer position)) - (dspec::dc-database (dspec::find-dc 'function)))) - (defimplementation compile-string-for-emacs (string &key buffer position) (assert buffer) (assert position) - (let ((*package* *buffer-package*) - (compiler::*error-database* '()) - (tmpname (hcl:make-temp-file nil "lisp"))) + (let* ((*package* *buffer-package*) + (location (list :emacs-buffer buffer position string)) + (compiler::*error-database* '()) + (tmpname (hcl:make-temp-file nil "lisp"))) (with-compilation-unit () - (compile-from-temp-file string tmpname) - (format t "~A~%" compiler:*messages*) - (signal-error-data-base - compiler::*error-database* tmpname buffer position) - (signal-undefined-functions compiler::*unknown-functions* - tmpname tmpname buffer position) - (patch-source-locations tmpname buffer position)))) + (compile-from-temp-file + (with-standard-io-syntax + (format nil "~S~%~A" `(eval-when (:compile-toplevel) + (setq dspec::*location* (list , at location))) + string)) + tmpname) + (signal-error-data-base compiler::*error-database* location) + (signal-undefined-functions compiler::*unknown-functions* location)))) ;;; xref From heller at common-lisp.net Wed Mar 3 07:18:02 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 02:18:02 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13440 Modified Files: swank.lisp Log Message: (find-completions): Deleted. (simple-completions): Use longest-common-prefix instead of longest-completion. (inspect-in-frame): Moved here from swank-cmucl.lisp. Date: Wed Mar 3 02:18:02 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.131 slime/swank.lisp:1.132 --- slime/swank.lisp:1.131 Mon Mar 1 10:46:27 2004 +++ slime/swank.lisp Wed Mar 3 02:18:02 2004 @@ -768,7 +768,7 @@ ;; Beware of recursive errors in printing, so only use the condition ;; if it is printable itself: (format nil "Unable to display error condition~@[: ~A~]" - (ignore-errors (princ-to-string cond)))))) + (ignore-errors (princ-to-string cond)))))) (defun debugger-condition-for-emacs () (list (safe-condition-message *swank-debugger-condition*) @@ -1082,10 +1082,6 @@ :upcase :downcase))) (format-completion-set completions internal-p package-name)))) -(defun find-completions (string default-package-name matchp) - (let ((completion-set (completion-set string default-package-name matchp))) - (list completion-set (longest-completion completion-set)))) - (defslimefun completions (string default-package-name) "Return a list of completions for a symbol designator STRING. @@ -1104,11 +1100,15 @@ FOO - Symbols with matching prefix and accessible in the buffer package. PKG:FOO - Symbols with matching prefix and external in package PKG. PKG::FOO - Symbols with matching prefix and accessible in package PKG." - (find-completions string default-package-name #'compound-prefix-match)) + (let ((completion-set (completion-set string default-package-name + #'compound-prefix-match))) + (list completion-set (longest-completion completion-set)))) (defslimefun simple-completions (string default-package-name) "Return a list of completions for a symbol designator STRING." - (find-completions string default-package-name #'prefix-match-p)) + (let ((completion-set (completion-set string default-package-name + #'prefix-match-p))) + (list completion-set (longest-common-prefix completion-set)))) (defun tokenize-symbol-designator (string) "Parse STRING as a symbol designator. @@ -1161,6 +1161,8 @@ ;;;;; Extending the input string by completion +;; XXX (longest-completion '("muffle-warning" "multiple-value-bind")) +;; => "mu-". Shouldn't that be "mu"? (defun longest-completion (completions) "Return the longest prefix for all COMPLETIONS." (untokenize-completion @@ -1177,7 +1179,7 @@ collect (subseq string start end))) (defun untokenize-completion (tokens) - (format nil "~{~A~^-~}" tokens)) + (format nil "~{~A~^-~}" tokens)) (defun longest-common-prefix (strings) "Return the longest string that is a common prefix of STRINGS." @@ -1494,6 +1496,10 @@ (t (push (cons (string 'rest) in-list) reversed-elements) (done "The object is an improper list of length ~S.~%"))))))) + +(defslimefun inspect-in-frame (string index) + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index))) ;;;; Thread listing From heller at common-lisp.net Wed Mar 3 07:26:54 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 02:26:54 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv320 Modified Files: slime.el Log Message: (slime-compilation-finished-hook): Use slime-maybe-list-compiler-notes as default. (slime-maybe-list-compiler-notes): New function. (slime-list-compiler-notes): Insert "[no notes]" if there aren't any. Pop to the buffer. (slime-complete-symbol*, slime-simple-complete-symbol): Set the lisp-mode-syntax-table in the completion buffer. (check-parens): Compatibility function for XEmacs and Emacs 20. Date: Wed Mar 3 02:26:54 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.225 slime/slime.el:1.226 --- slime/slime.el:1.225 Sun Feb 29 04:05:05 2004 +++ slime/slime.el Wed Mar 3 02:26:54 2004 @@ -255,11 +255,13 @@ (def-sldb-face local-value "local variable values") (def-sldb-face catch-tag "catch tags") -(defcustom slime-compilation-finished-hook '() +(defcustom slime-compilation-finished-hook 'slime-maybe-list-compiler-notes "Hook called with a list of compiler notes after a compilation." :group 'slime :type 'hook - :options '(slime-list-compiler-notes slime-maybe-show-xrefs-for-notes)) + :options '(slime-maybe-list-compiler-notes + slime-list-compiler-notes + slime-maybe-show-xrefs-for-notes)) (defcustom slime-complete-symbol-function 'slime-complete-symbol* "Function to perform symbol completion." @@ -2471,6 +2473,13 @@ (slime-show-xrefs xrefs 'definition "Compiler notes" (slime-buffer-package))))) +(defun slime-maybe-list-compiler-notes (notes) + "Show the compiler notes if appropriate. +Useful value for `slime-compilation-finished-hook'" + (unless (or (null notes) + (eq last-command 'slime-compile-defun)) + (slime-list-compiler-notes notes))) + (defun slime-list-compiler-notes (&optional notes) "Show the compiler notes NOTES in tree view." (interactive) @@ -2478,6 +2487,8 @@ (with-current-buffer (get-buffer-create "*compiler notes*") (let ((inhibit-read-only t)) (erase-buffer) + (when (null notes) + (insert "[no notes]")) (dolist (tree (slime-compiler-notes-to-tree notes)) (slime-tree-insert tree "") (insert "\n"))) @@ -2486,7 +2497,7 @@ (make-local-variable 'slime-compiler-notes-saved-window-configuration) (setq slime-compiler-notes-saved-window-configuration (current-window-configuration)) - (display-buffer (current-buffer))))) + (pop-to-buffer (current-buffer))))) (defun slime-alistify (list key test) "Partition the elements of LIST into an alist. KEY extracts the key @@ -3281,6 +3292,7 @@ (goto-char (+ beg unambiguous-completion-length)) (slime-complete-maybe-save-window-configuration) (with-output-to-temp-buffer "*Completions*" + (set-syntax-table lisp-mode-syntax-table) (display-completion-list completion-set)) (slime-complete-delay-restoration))))))) @@ -3308,6 +3320,7 @@ (slime-minibuffer-respecting-message "Complete but not unique") (slime-complete-maybe-save-window-configuration) (with-output-to-temp-buffer "*Completions*" + (set-syntax-table lisp-mode-syntax-table) (display-completion-list completion-set)) (slime-complete-delay-restoration))))))) @@ -5803,6 +5816,39 @@ (forward-line n) (beginning-of-line) (point))) + +(defun-if-undefined check-parens () + "Verify that parentheses in the current buffer are balanced. +If they are not, position point at the first syntax error found." + (interactive) + (let ((saved-point (point)) + (state (parse-partial-sexp (point-min) (point-max) -1))) + (destructuring-bind (depth innermost-start last-terminated-start + in-string in-comment after-quote + minimum-depth comment-style + comment-or-string-start &rest _) state + (cond ((and (zerop depth) + (not in-string) + (or (not in-comment) + (and (eq comment-style nil) + (eobp))) + (not after-quote)) + (goto-char saved-point) + (message "All parentheses appear to be balanced.")) + ((plusp depth) + (goto-char innermost-start) + (error "Missing )")) + ((minusp depth) + (error "Extra )")) + (in-string + (goto-char comment-or-string-start) + (error "String not terminated")) + (in-comment + (goto-char comment-or-string-start) + (error "Comment not terminated")) + (after-quote + (error "After quote")) + (t (error "Shouldn't happen: parsing state: %S" state)))))) (unless (boundp 'temporary-file-directory) (defvar temporary-file-directory From heller at common-lisp.net Wed Mar 3 07:28:48 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 02:28:48 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14656 Modified Files: swank-cmucl.lisp Log Message: ((resolve-note-location t nil nil nil nil)) Don't be too clever. (compile-file-for-emacs): Use the :load argument to compile-file. (inspect-in-frame): Deleted. Date: Wed Mar 3 02:28:48 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.73 slime/swank-cmucl.lisp:1.74 --- slime/swank-cmucl.lisp:1.73 Mon Mar 1 04:02:15 2004 +++ slime/swank-cmucl.lisp Wed Mar 3 02:28:48 2004 @@ -339,15 +339,17 @@ (pos (eql nil)) (path (eql nil)) (source (eql nil))) + (list :error "No error location available") + #+(or) (cond (buffer (make-location (list :buffer buffer) (list :position *buffer-start-position*))) (*compile-file-truename* (make-location (list :file (namestring *compile-file-truename*)) - (list :position 0))) + (list :source-path '(0) 1))) (*compile-filename* (make-location (list :file *compile-filename*) - (list :position 0))) + (list :source-path '(0) 1))) (t (list :error "No error location available")))) @@ -365,9 +367,7 @@ (with-compilation-hooks () (let ((*buffer-name* nil) (*compile-filename* filename)) - (let ((fasl-file (compile-file filename))) - (when (and load-p fasl-file) - (load fasl-file)))))) + (compile-file filename :load load-p)))) (defimplementation compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () @@ -1026,10 +1026,6 @@ (swank-pprint (multiple-value-list (di:eval-in-frame (nth-frame index) (from-string string))))) - -(defslimefun inspect-in-frame (string index) - (reset-inspector) - (inspect-object (di:eval-in-frame (nth-frame index) (from-string string)))) (defimplementation frame-locals (index) (let* ((frame (nth-frame index)) From heller at common-lisp.net Wed Mar 3 07:34:36 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 02:34:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15638 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Mar 3 02:34:35 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.276 slime/ChangeLog:1.277 --- slime/ChangeLog:1.276 Mon Mar 1 10:46:27 2004 +++ slime/ChangeLog Wed Mar 3 02:34:35 2004 @@ -1,3 +1,38 @@ +2004-03-03 Helmut Eller + + * swank-cmucl.lisp (resolve-note-location): Don't be too clever, + if there is no context available. The compiler notes buffer is + probably more adequate in this situation. + (compile-file-for-emacs): Use the :load argument to compile-file. + (inspect-in-frame): Deleted. + + * slime.el (slime-compilation-finished-hook): Use + slime-maybe-list-compiler-notes as default. + (slime-maybe-list-compiler-notes): New function. + (slime-list-compiler-notes): Insert "[no notes]" if there aren't + any. Pop to the buffer. + (slime-complete-symbol*, slime-simple-complete-symbol): Set the + lisp-mode-syntax-table in the completion buffer. + (check-parens): Compatibility function for XEmacs and Emacs 20. + + * swank.lisp (find-completions): Deleted. + (simple-completions): Use longest-common-prefix instead of + longest-completion. + (inspect-in-frame): Moved here from swank-cmucl.lisp. + + * swank-lispworks.lisp (call-with-debugging-environment): Bind + *sldb-top-frame*. + (nth-frame): Use *sldb-top-frame*. + (name-source-location, name-source-locations): Renamed from + dspec-source-location, dspec-source-locations. The result now + includes methods for generic functions. + (eval-in-frame, return-from-frame, restart-frame): Implemented. + (compile-string-for-emacs): Set dspec::*location* to the buffer + location. + (signal-undefined-functions, signal-error-data-base) + (make-dspec-location): Remove temp-file kludges. + (patch-source-locations, replace-source-file): Deleted. + 2004-03-01 Marco Baringer * swank.lisp (format-arglist): deal with nil arglists. From heller at common-lisp.net Wed Mar 3 08:51:25 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 03:51:25 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21410 Modified Files: swank.lisp Log Message: (setup-server, serve-connection): New dont-close argument to keep the socket open after the first request. (start-server, create-swank-server): Update callers. Date: Wed Mar 3 03:51:25 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.132 slime/swank.lisp:1.133 --- slime/swank.lisp:1.132 Wed Mar 3 02:18:02 2004 +++ slime/swank.lisp Wed Mar 3 03:51:24 2004 @@ -156,30 +156,36 @@ (defvar *swank-in-background* nil) (defvar *log-events* nil) -(defun start-server (port-file &optional (background *swank-in-background*)) +(defun start-server (port-file &optional (background *swank-in-background*) + dont-close) (setup-server 0 (lambda (port) (announce-server-port port-file port)) - background)) + background dont-close)) (defun create-swank-server (&optional (port +server-port+) (background *swank-in-background*) - (announce-fn #'simple-announce-function)) - (setup-server port announce-fn background)) + (announce-fn #'simple-announce-function) + dont-close) + (setup-server port announce-fn background dont-close)) (defparameter *loopback-interface* "127.0.0.1") -(defun setup-server (port announce-fn style) +(defun setup-server (port announce-fn style dont-close) (declare (type function announce-fn)) (let* ((socket (create-socket *loopback-interface* port)) (port (local-port socket))) (funcall announce-fn port) (cond ((eq style :spawn) - (spawn (lambda () (serve-connection socket :spawn)) :name "Swank")) - (t (serve-connection socket style))) + (spawn (lambda () + (loop do (serve-connection socket :spawn dont-close) + while dont-close)) + :name "Swank")) + (t (serve-connection socket style nil))) port)) -(defun serve-connection (socket style) +(defun serve-connection (socket style dont-close) (let ((client (accept-connection socket))) - (close-socket socket) + (unless dont-close + (close-socket socket)) (let ((connection (create-connection client style))) (init-emacs-connection connection) (serve-requests connection)))) From heller at common-lisp.net Wed Mar 3 08:53:54 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 03:53:54 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32024 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Mar 3 03:53:53 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.277 slime/ChangeLog:1.278 --- slime/ChangeLog:1.277 Wed Mar 3 02:34:35 2004 +++ slime/ChangeLog Wed Mar 3 03:53:53 2004 @@ -1,5 +1,10 @@ 2004-03-03 Helmut Eller + * swank.lisp (setup-server, serve-connection): New dont-close + argument to keep the socket open after the first connection. + (start-server, create-swank-server): Update callers. + Reported by Bill Clementson. + * swank-cmucl.lisp (resolve-note-location): Don't be too clever, if there is no context available. The compiler notes buffer is probably more adequate in this situation. @@ -18,8 +23,8 @@ * swank.lisp (find-completions): Deleted. (simple-completions): Use longest-common-prefix instead of longest-completion. - (inspect-in-frame): Moved here from swank-cmucl.lisp. - + (inspect-in-frame): Moved here from swank-cmucl.lisp. + * swank-lispworks.lisp (call-with-debugging-environment): Bind *sldb-top-frame*. (nth-frame): Use *sldb-top-frame*. From heller at common-lisp.net Wed Mar 3 20:52:41 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 15:52:41 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14656 Modified Files: swank.lisp Log Message: Use *emacs-connection*, *active-threads*, and *thread-counter* as thread local dynamic variables. (init-emacs-connection): Don't set *emacs-connection*. (create-connection, dispatch-event): Pass the connection object to newly created threads. (with-connection): New macro (handle-request, install-fd-handler, debug-thread): Use it. Date: Wed Mar 3 15:52:40 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.133 slime/swank.lisp:1.134 --- slime/swank.lisp:1.133 Wed Mar 3 03:51:24 2004 +++ slime/swank.lisp Wed Mar 3 15:52:40 2004 @@ -75,8 +75,8 @@ (user-output nil :type (or stream null)) (user-io nil :type (or stream null)) ;; - (control-thread nil :read-only t) - (reader-thread nil :read-only t) + control-thread + reader-thread (read (missing-arg) :type function) (send (missing-arg) :type function) (serve-requests (missing-arg) :type function) @@ -108,12 +108,11 @@ ;;;; Helper macros -(defmacro with-io-redirection ((&rest ignore) &body body) +(defmacro with-io-redirection ((connection) &body body) "Execute BODY with I/O redirection to CONNECTION. If *REDIRECT-IO* is true, all standard I/O streams are redirected." - (declare (ignore ignore)) `(if *redirect-io* - (call-with-redirected-io *emacs-connection* (lambda () , at body)) + (call-with-redirected-io ,connection (lambda () , at body)) (progn , at body))) (defmacro without-interrupts (&body body) @@ -195,7 +194,7 @@ (funcall (connection.serve-requests connection) connection)) (defun init-emacs-connection (connection) - (setq *emacs-connection* connection) + (declare (ignore connection)) (emacs-connected)) (defun announce-server-port (file port) @@ -245,16 +244,22 @@ (encode-message `(:open-dedicated-output-stream ,port) socket-io) (accept-connection socket))) -(defun handle-request () +(defmacro with-connection ((connection) &body body) + "Execute BODY in the context of CONNECTION." + `(let ((*emacs-connection* ,connection)) + (catch 'slime-toplevel + (with-simple-restart (abort "Return to SLIME toplevel.") + (with-io-redirection (connection) + (let ((*debugger-hook* #'swank-debugger-hook)) + , at body)))))) + +(defun handle-request (connection) "Read and process one request. The processing is done in the extend of the toplevel restart." (assert (null *swank-state-stack*)) (let ((*swank-state-stack* '(:handle-request))) - (catch 'slime-toplevel - (with-simple-restart (abort "Return to SLIME toplevel.") - (with-io-redirection () - (let ((*debugger-hook* #'swank-debugger-hook)) - (read-from-emacs))))))) + (with-connection (connection) + (read-from-emacs)))) (defun changelog-date () "Return the datestring of the latest ChangeLog entry. The date is @@ -287,8 +292,8 @@ `(handler-case (progn , at body) (slime-read-error (e) (close-connection ,connection e)))) -(defun read-loop (control-thread input-stream) - (with-reader-error-handler (*emacs-connection*) +(defun read-loop (control-thread input-stream connection) + (with-reader-error-handler (connection) (loop (send control-thread (decode-message input-stream))))) (defvar *active-threads* '()) @@ -330,11 +335,12 @@ (noerror nil) (t (error "Thread id not found ~S" id))))) -(defun dispatch-loop (socket-io) - (setq *active-threads* '()) - (setq *thread-counter* 0) - (loop (with-simple-restart (abort "Retstart dispatch loop.") - (loop (dispatch-event (receive) socket-io))))) +(defun dispatch-loop (socket-io connection) + (let ((*emacs-connection* connection) + (*active-threads* '()) + (*thread-counter* 0)) + (loop (with-simple-restart (abort "Retstart dispatch loop.") + (loop (dispatch-event (receive) socket-io)))))) (defun simple-break () (with-simple-restart (continue "Continue from interrupt.") @@ -354,7 +360,10 @@ (destructure-case event ((:emacs-rex string package thread id) (let ((thread (etypecase thread - ((member t) (spawn #'handle-request :name "worker")) + ((member t) + (let ((c *emacs-connection*)) + (spawn (lambda () (handle-request c)) + :name "worker"))) (fixnum (lookup-thread-id thread))))) (send thread `(eval-string ,string ,package ,id)) (add-thread thread))) @@ -382,18 +391,23 @@ (multiple-value-bind (dedicated in out io) (open-streams socket-io) (ecase style (:spawn - (let* ((control-thread (spawn (lambda () (dispatch-loop socket-io)) - :name "control-thread")) - (reader-thread (spawn (lambda () - (read-loop control-thread socket-io)) - :name "reader-thread"))) - (make-connection :socket-io socket-io :dedicated-output dedicated - :user-input in :user-output out :user-io io - :control-thread control-thread - :reader-thread reader-thread - :read #'read-from-control-thread - :send #'send-to-control-thread - :serve-requests (lambda (c) c)))) + (let ((connection + (make-connection :socket-io socket-io :dedicated-output dedicated + :user-input in :user-output out :user-io io + :read #'read-from-control-thread + :send #'send-to-control-thread + :serve-requests (lambda (c) c)))) + (let ((control-thread (spawn (lambda () + (dispatch-loop socket-io connection)) + :name "control-thread"))) + (setf (connection.control-thread connection) control-thread) + (let ((reader-thread (spawn (lambda () + (read-loop control-thread + socket-io + connection)) + :name "reader-thread"))) + (setf (connection.reader-thread connection) reader-thread) + connection)))) (:sigio (make-connection :socket-io socket-io :dedicated-output dedicated :user-input in :user-output out :user-io io @@ -424,12 +438,13 @@ (defun install-sigio-handler (connection) (let ((client (connection.socket-io connection))) - (flet ((handler () - (cond ((null *swank-state-stack*) - (with-reader-error-handler (connection) - (process-available-input client #'handle-request))) - ((eq (car *swank-state-stack*) :read-next-form)) - (t (process-available-input client #'read-from-emacs))))) + (flet ((handler () + (cond ((null *swank-state-stack*) + (with-reader-error-handler (connection) + (process-available-input + client (lambda () (handle-request connection))))) + ((eq (car *swank-state-stack*) :read-next-form)) + (t (process-available-input client #'read-from-emacs))))) (add-sigio-handler client #'handler) (handler)))) @@ -441,17 +456,18 @@ (defun install-fd-handler (connection) (let ((client (connection.socket-io connection))) (flet ((handler () - (cond ((null *swank-state-stack*) - (with-reader-error-handler (connection) - (process-available-input client #'handle-request))) - ((eq (car *swank-state-stack*) :read-next-form)) - (t (process-available-input client #'read-from-emacs))))) + (cond ((null *swank-state-stack*) + (with-reader-error-handler (connection) + (process-available-input + client (lambda () (handle-request connection))))) + ((eq (car *swank-state-stack*) :read-next-form)) + (t (process-available-input client #'read-from-emacs))))) (encode-message '(:use-sigint-for-interrupt) client) (setq *debugger-hook* (lambda (c h) - (with-reader-error-handler (connection) + (with-reader-error-handler (connection) (block debugger - (catch 'slime-toplevel + (with-connection (connection) (swank-debugger-hook c h) (return-from debugger)) (abort))))) @@ -467,7 +483,7 @@ (let ((socket-io (connection.socket-io connection))) (encode-message '(:use-sigint-for-interrupt) socket-io) (with-reader-error-handler (connection) - (loop (handle-request))))) + (loop (handle-request connection))))) (defun read-from-socket-io () (let ((event (decode-message (current-socket-io)))) @@ -1526,30 +1542,14 @@ (setq *thread-list* nil)) (defun lookup-thread-by-id (id) - (nth id (all-threads))) + (nth id *thread-list*)) (defun debug-thread (thread-id) - (interrupt-thread (lookup-thread-by-id thread-id) - (let ((pack *package*)) + (let ((connection *emacs-connection*)) + (interrupt-thread (lookup-thread-by-id thread-id) (lambda () - (catch 'slime-toplevel - (let ((*debugger-hook* (lambda (c h) - (declare (ignore h)) - ;; cut 'n paste from swank-debugger-hook - (let ((*swank-debugger-condition* c) - (*buffer-package* pack) - (*package* pack) - (*sldb-level* (1+ *sldb-level*)) - (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))) - (force-user-output) - (call-with-debugging-environment - (lambda () (sldb-loop *sldb-level*))))))) - (restart-case - (error (make-condition 'simple-error - :format-control "Interrupt from Emacs")) - (un-interrupt () - :report "Abandon control of this thread." - nil)))))))) + (with-connection (connection) + (simple-break)))))) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From heller at common-lisp.net Wed Mar 3 20:55:38 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 15:55:38 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-clisp.lisp slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22432 Modified Files: swank-cmucl.lisp swank-sbcl.lisp swank-openmcl.lisp swank-clisp.lisp swank-allegro.lisp Log Message: (call-with-compilation-hooks): Bind fewer variables. Most of them are already bound in swank.lisp. Date: Wed Mar 3 15:55:38 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.74 slime/swank-cmucl.lisp:1.75 --- slime/swank-cmucl.lisp:1.74 Wed Mar 3 02:28:48 2004 +++ slime/swank-cmucl.lisp Wed Mar 3 15:55:38 2004 @@ -964,12 +964,7 @@ (unix:unix-sigsetmask 0) (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame))) (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) - (debug:*stack-top-hint* nil) - (*debugger-hook* nil) - (*readtable* (or debug:*debug-readtable* *readtable*)) - (*print-level* debug:*debug-print-level*) - (*print-length* debug:*debug-print-length*) - (*print-readably* nil)) + (debug:*stack-top-hint* nil)) (handler-bind ((di:debug-condition (lambda (condition) (signal (make-condition Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.70 slime/swank-sbcl.lisp:1.71 --- slime/swank-sbcl.lisp:1.70 Mon Mar 1 04:02:23 2004 +++ slime/swank-sbcl.lisp Wed Mar 3 15:55:38 2004 @@ -466,12 +466,7 @@ (declare (type function debugger-loop-fn)) (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame))) (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) - (sb-debug:*stack-top-hint* nil) - (*debugger-hook* nil) - (*readtable* (or sb-debug:*debug-readtable* *readtable*)) - (*print-level* 4 #+nil sb-debug:*debug-print-level*) - (*print-length* 10 #+nil sb-debug:*debug-print-length*) - (*print-readably* nil)) + (sb-debug:*stack-top-hint* nil)) (handler-bind ((sb-di:debug-condition (lambda (condition) (signal (make-condition Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.66 slime/swank-openmcl.lisp:1.67 --- slime/swank-openmcl.lisp:1.66 Fri Feb 27 07:32:06 2004 +++ slime/swank-openmcl.lisp Wed Mar 3 15:55:38 2004 @@ -231,14 +231,8 @@ (defimplementation call-with-debugging-environment (debugger-loop-fn) (let* ((*sldb-stack-top* nil) - ;; This is a complete hack --- since we're not running at top level we - ;; don't want to publish the last restart to Emacs which would allow - ;; the user to break outside of the request loop. What's the right - ;; way to do this? - (*sldb-restarts* (butlast - (compute-restarts *swank-debugger-condition*))) + (*sldb-restarts* (compute-restarts *swank-debugger-condition*)) (*debugger-hook* nil) - (*package* *buffer-package*) (ccl::*signal-printing-errors* nil)) ; don't let error while printing error take us down (funcall debugger-loop-fn))) Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.21 slime/swank-clisp.lisp:1.22 --- slime/swank-clisp.lisp:1.21 Tue Feb 24 18:31:34 2004 +++ slime/swank-clisp.lisp Wed Mar 3 15:55:38 2004 @@ -225,14 +225,7 @@ (sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*) sys::*debug-mode*)) (*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*)) - (*debugger-hook* nil) - (*package* *buffer-package*) - (*sldb-restarts* - (compute-restarts *swank-debugger-condition*)) - (*print-pretty* nil) - (*print-readably* nil)) -;;; (*print-level* 3) -;;; (*print-length* 10)) + (*sldb-restarts* (compute-restarts *swank-debugger-condition*))) (funcall debugger-loop-fn))) (defun format-restarts-for-emacs () Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.16 slime/swank-allegro.lisp:1.17 --- slime/swank-allegro.lisp:1.16 Mon Mar 1 04:02:06 2004 +++ slime/swank-allegro.lisp Wed Mar 3 15:55:38 2004 @@ -109,15 +109,9 @@ (defimplementation call-with-debugging-environment (debugger-loop-fn) (let ((*sldb-topframe* (excl::int-newest-frame)) - (*debugger-hook* nil) (excl::*break-hook* nil) - (*package* *buffer-package*) (*sldb-restarts* - (compute-restarts *swank-debugger-condition*)) - (*print-pretty* nil) - (*print-readably* nil) - (*print-level* 3) - (*print-length* 10)) + (compute-restarts *swank-debugger-condition*))) (funcall debugger-loop-fn))) (defun format-restarts-for-emacs () From heller at common-lisp.net Wed Mar 3 20:57:47 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 03 Mar 2004 15:57:47 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13312 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Mar 3 15:57:46 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.278 slime/ChangeLog:1.279 --- slime/ChangeLog:1.278 Wed Mar 3 03:53:53 2004 +++ slime/ChangeLog Wed Mar 3 15:57:46 2004 @@ -1,5 +1,18 @@ 2004-03-03 Helmut Eller + * swank.lisp: Use *emacs-connection*, *active-threads*, and + *thread-counter* as thread local dynamic variables. + (init-emacs-connection): Don't set *emacs-connection*. + (create-connection, dispatch-event): Pass the connection object to + newly created threads. + (with-connection): New macro + (handle-request, install-fd-handler, debug-thread): Use it. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-openmcl.lisp, swank-sbcl.lisp (call-with-compilation-hooks): + Bind fewer variables. Most of them are already bound in + swank.lisp. + * swank.lisp (setup-server, serve-connection): New dont-close argument to keep the socket open after the first connection. (start-server, create-swank-server): Update callers. From ucdsn at cxe-equip.com Thu Mar 4 17:21:04 2004 From: ucdsn at cxe-equip.com (Reinaldo Britt) Date: Thu, 04 Mar 2004 14:21:04 -0300 Subject: [slime-cvs] Re: Xanax, "Viagra", Xanax, Prozac and more! Message-ID: An HTML attachment was scrubbed... URL: From heller at common-lisp.net Thu Mar 4 22:12:45 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Mar 2004 17:12:45 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv24800 Modified Files: swank.lisp Log Message: (remove-dead-threads): New function. (lookup-thread): Use it. (print-arglist): New function. This time without binding pretty dispatch table. (format-arglist): Use it. (inspected-parts): Add method for hash-tables. Date: Thu Mar 4 17:12:44 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.134 slime/swank.lisp:1.135 --- slime/swank.lisp:1.134 Wed Mar 3 15:52:40 2004 +++ slime/swank.lisp Thu Mar 4 17:12:44 2004 @@ -299,6 +299,10 @@ (defvar *active-threads* '()) (defvar *thread-counter* 0) +(defun remove-dead-threads () + (setq *active-threads* + (remove-if-not #'thread-alive-p *active-threads*))) + (defun add-thread (thread) (let ((id (mod (1+ *thread-counter*) most-positive-fixnum))) (setq *active-threads* (acons id thread *active-threads*) @@ -324,7 +328,13 @@ (assert pair) (car pair))) +(defvar *lookup-counter* nil + "A simple counter used to remove dead threads from *active-threads*.") + (defun lookup-thread (thread) + (when (zerop (decf *lookup-counter*)) + (setf *lookup-counter* 50) + (remove-dead-threads)) (let ((probe (rassoc thread *active-threads*))) (cond (probe (car probe)) (t (add-thread thread))))) @@ -338,7 +348,8 @@ (defun dispatch-loop (socket-io connection) (let ((*emacs-connection* connection) (*active-threads* '()) - (*thread-counter* 0)) + (*thread-counter* 0) + (*lookup-counter* 50)) (loop (with-simple-restart (abort "Retstart dispatch loop.") (loop (dispatch-event (receive) socket-io)))))) @@ -718,12 +729,38 @@ (let ((symbol (find-symbol-or-lose function-name))) (values (funcall lambda-list-fn symbol)))) (cond (condition (format nil "(-- ~A)" condition)) - (t (if (null arglist) + (t (if (null arglist) "()" - (let ((*print-case* :downcase) - (*print-level* nil) - (*print-length* nil)) - (princ-to-string arglist))))))) + (print-arglist-to-string arglist)))))) + +(defun print-arglist-to-string (arglist) + (with-output-to-string (*standard-output*) + (print-arglist arglist))) + +(defun print-arglist (arglist) + (let ((*print-case* :downcase) + (*print-pretty* t)) + (pprint-logical-block (*standard-output* arglist :prefix "(" :suffix ")") + (loop + (let ((arg (pprint-pop))) + (etypecase arg + (symbol (princ arg)) + (cons (pprint-logical-block (*standard-output* arg :prefix "(" + :suffix ")") + (princ (car arg)) + (write-char #\space) + (pprint-fill *standard-output* (cdr arg) nil)))) + (pprint-exit-if-list-exhausted) + (write-char #\space) + (pprint-newline :fill)))))) + +(defun test-print-arglist (list string) + (string= (print-arglist-to-string list) string)) + +(assert (test-print-arglist '(function cons) "(function cons)")) +(assert (test-print-arglist '(quote cons) "(quote cons)")) +;; (assert (test-print-arglist '(&key (function #'f)) "(&key (function #'f))")) +;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))")) ;;;; Debugger @@ -1518,6 +1555,22 @@ (t (push (cons (string 'rest) in-list) reversed-elements) (done "The object is an improper list of length ~S.~%"))))))) + +(defmethod inspected-parts ((o hash-table)) + (values (format nil "~A~% is a ~A" o (class-of o)) + (list* + (cons "Test" (hash-table-test o)) + (cons "Count" (hash-table-count o)) + (cons "Size" (hash-table-size o)) + (cons "Rehash-Threshold" (hash-table-rehash-threshold o)) + (cons "Rehash-Size" (hash-table-rehash-size o)) + (cons "---" :---) + (let ((pairs '())) + (maphash (lambda (key value) + (push (cons (to-string key) value) + pairs)) + o) + pairs)))) (defslimefun inspect-in-frame (string index) (reset-inspector) From heller at common-lisp.net Thu Mar 4 22:15:40 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Mar 2004 17:15:40 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp slime/swank-allegro.lisp slime/swank-lispworks.lisp slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14565 Modified Files: swank-backend.lisp swank-allegro.lisp swank-lispworks.lisp swank-cmucl.lisp swank-sbcl.lisp swank-clisp.lisp Log Message: (thread-alive-p): Add default implementation. (describe-primitive-type): Add default implementation. (inspected-parts): Implemented for Allegro and CLISP. Date: Thu Mar 4 17:15:40 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.34 slime/swank-backend.lisp:1.35 --- slime/swank-backend.lisp:1.34 Fri Feb 27 07:32:06 2004 +++ slime/swank-backend.lisp Thu Mar 4 17:15:39 2004 @@ -524,12 +524,13 @@ ;;;; Inspector -(defgeneric inspected-parts (object) - (:documentation - "Return a short description and a list of (LABEL . VALUE) pairs.")) +(definterface inspected-parts (object) + "Return a short description and a list of (LABEL . VALUE) pairs." + (values (format nil "~S is an atom." object) '())) (definterface describe-primitive-type (object) - "Return a string describing the primitive type of object.") + "Return a string describing the primitive type of object." + "N/A") ;;;; Multiprocessing @@ -582,7 +583,8 @@ "Return a list of all threads.") (definterface thread-alive-p (thread) - "Test if THREAD is termintated.") + "Test if THREAD is termintated." + (member thread (all-threads))) (definterface interrupt-thread (thread fn) "Cause THREAD to execute FN.") Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.17 slime/swank-allegro.lisp:1.18 --- slime/swank-allegro.lisp:1.17 Wed Mar 3 15:55:38 2004 +++ slime/swank-allegro.lisp Thu Mar 4 17:15:40 2004 @@ -309,7 +309,19 @@ (push (cons (to-string fspec) location) xrefs))) (group-xrefs xrefs))) -;;;; Multiprocessing +;;;; Inspecting + +(defmethod inspected-parts (o) + (let* ((class (class-of o)) + (slots (clos:class-slots class))) + (values (format nil "~A~% is a ~A" o class) + (mapcar (lambda (slot) + (let ((name (clos:slot-definition-name slot))) + (cons (to-string name) + (slot-value o name)))) + slots)))) + +;;;; Multithreading (defimplementation startup-multiprocessing () (mp:start-scheduler)) Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.26 slime/swank-lispworks.lisp:1.27 --- slime/swank-lispworks.lisp:1.26 Wed Mar 3 02:08:33 2004 +++ slime/swank-lispworks.lisp Thu Mar 4 17:15:40 2004 @@ -429,10 +429,6 @@ ;;; Inspector -(defimplementation describe-primitive-type (object) - (declare (ignore object)) - "NYI") - (defmethod inspected-parts (o) (multiple-value-bind (names values _getter _setter type) (lw:get-inspector-values o nil) @@ -475,6 +471,9 @@ (defimplementation kill-thread (thread) (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) (defvar *mailbox-lock* (mp:make-lock)) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.75 slime/swank-cmucl.lisp:1.76 --- slime/swank-cmucl.lisp:1.75 Wed Mar 3 15:55:38 2004 +++ slime/swank-cmucl.lisp Thu Mar 4 17:15:40 2004 @@ -1227,17 +1227,16 @@ (with-output-to-string (*standard-output*) (let* ((lowtag (kernel:get-lowtag object)) (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) - (format t "[lowtag: ~A" lowtag-symbol) - (cond ((member lowtag (list vm:other-pointer-type - vm:function-pointer-type - vm:other-immediate-0-type - vm:other-immediate-1-type - )) - (let* ((type (kernel:get-type object)) - (type-symbol (find type +header-type-symbols+ - :key #'symbol-value))) - (format t ", type: ~A]" type-symbol))) - (t (format t "]")))))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) (defimplementation inspected-parts (o) (cond ((di::indirect-value-cell-p o) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.71 slime/swank-sbcl.lisp:1.72 --- slime/swank-sbcl.lisp:1.71 Wed Mar 3 15:55:38 2004 +++ slime/swank-sbcl.lisp Thu Mar 4 17:15:40 2004 @@ -649,10 +649,6 @@ ;;;; Inspector -(defimplementation describe-primitive-type (object) - (declare (ignore object)) - "NYI") - (defmethod inspected-parts (o) (cond ((sb-di::indirect-value-cell-p o) (inspected-parts-of-value-cell o)) Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.22 slime/swank-clisp.lisp:1.23 --- slime/swank-clisp.lisp:1.22 Wed Mar 3 15:55:38 2004 +++ slime/swank-clisp.lisp Thu Mar 4 17:15:40 2004 @@ -160,7 +160,7 @@ (defun find-multiple-definitions (fspec) (list `(,fspec t))) - +(fspec-pathname 'disassemble) (defun find-definition-in-file (fspec type file) (declare (ignore fspec type file)) ;; FIXME @@ -509,6 +509,31 @@ (with-condition-restarts condition (list (find-restart 'CONTINUE)) (invoke-debugger condition))))) nil)) + +;;; Inspecting + +(defmethod inspected-parts (o) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (values (format nil "~S~% ~A~{~%~A~}" o + (sys::insp-title inspection) + (sys::insp-blurb inspection)) + (let ((count (sys::insp-num-slots inspection)) + (pairs '())) + (dotimes (i count) + (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) i) + (push (cons (to-string (or name i)) value) + pairs))) + (nreverse pairs)))))) ;;; Local Variables: ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1) From heller at common-lisp.net Thu Mar 4 22:19:26 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Mar 2004 17:19:26 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17952 Modified Files: slime.el Log Message: (slime-display-comletion-list): New function. Set syntax table properly. (slime-complete-symbol*, slime-simple-complete-symbol): Use it. (slime-update-connection-list): New function. (slime-draw-connection-list): Simplified. (slime-connection-list-mode-map): Bind g to update-connection-list. (slime-open-inspector): Print the primitive type in brackets. (slime-test-arglist): Add test for empty arglist. Date: Thu Mar 4 17:19:26 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.226 slime/slime.el:1.227 --- slime/slime.el:1.226 Wed Mar 3 02:26:54 2004 +++ slime/slime.el Thu Mar 4 17:19:26 2004 @@ -845,7 +845,8 @@ (interactive) (let ((config slime-temp-buffer-saved-window-configuration)) (kill-buffer (current-buffer)) - (set-window-configuration config))) + (when config + (set-window-configuration config)))) (defvar slime-temp-buffer-map) @@ -1353,6 +1354,8 @@ (\, store))) '(\, varname)))) +(put 'slime-def-connection-var 'lisp-indent-function 2) + (slime-def-connection-var slime-lisp-features '() "The symbol-names of Lisp's *FEATURES*. This is automatically synchronized from Lisp.") @@ -1374,10 +1377,10 @@ (slime-def-connection-var slime-use-sigint-for-interrupt nil "If non-nil use a SIGINT for interrupting.") -(put 'slime-def-connection-var 'lisp-indent-function 2) - +;; XXX pending continuations not removed if Lisp crashes. Multiple +;; sessions complicate the issue. Better make this a connection variable? (defvar slime-rex-continuations '() "List of (ID . FUNCTION) continuations waiting for RPC results.") @@ -3007,7 +3010,10 @@ (interactive "p") (self-insert-command n) (when (and (slime-connected-p) - (not (slime-busy-p)) + (or (not (slime-busy-p)) + ;; XXX should we enable this? + ;; (not slime-use-sigint-for-interrupt)) + ) (slime-function-called-at-point/line)) (slime-arglist (symbol-name (slime-function-called-at-point/line))))) @@ -3291,11 +3297,15 @@ (length completed-prefix))))) (goto-char (+ beg unambiguous-completion-length)) (slime-complete-maybe-save-window-configuration) - (with-output-to-temp-buffer "*Completions*" - (set-syntax-table lisp-mode-syntax-table) - (display-completion-list completion-set)) + (slime-display-comletion-list completion-set) (slime-complete-delay-restoration))))))) +(defun slime-display-comletion-list (completion-list) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list completion-set) + (with-current-buffer standard-output + (set-syntax-table lisp-mode-syntax-table)))) + (defun* slime-simple-complete-symbol () "Complete the symbol at point. Perform completion more similar to Emacs' complete-symbol." @@ -3319,9 +3329,7 @@ (t (slime-minibuffer-respecting-message "Complete but not unique") (slime-complete-maybe-save-window-configuration) - (with-output-to-temp-buffer "*Completions*" - (set-syntax-table lisp-mode-syntax-table) - (display-completion-list completion-set)) + (slime-display-comletion-list completion-set) (slime-complete-delay-restoration))))))) (defun slime-minibuffer-respecting-message (format &rest format-args) @@ -4720,7 +4728,7 @@ '(swank:list-threads) nil (lambda (threads) - (with-current-buffer (get-buffer-create "*slime-threads*") + (with-current-buffer (get-buffer-create "*slime-threads*") (slime-thread-control-mode) (let ((inhibit-read-only t)) (erase-buffer) @@ -4799,6 +4807,7 @@ (slime-define-keys slime-connection-list-mode-map ((kbd "RET") 'slime-goto-connection) ("d" 'slime-connection-list-make-default) + ("g" 'slime-update-connection-list) ("q" 'slime-temp-buffer-quit)) (defun slime-connection-at-point () @@ -4812,39 +4821,49 @@ (defun slime-connection-list-make-default () (interactive) - (let ((slime-dispatching-connection (slime-connection-at-point))) - (slime-make-default-connection) - (slime-draw-connection-list))) + (slime-select-connection (slime-connection-at-point)) + (slime-update-connection-list)) (defun slime-list-connections () "Display a list of all connections." (interactive) (when (get-buffer "*SLIME connections*") (kill-buffer "*SLIME connections*")) - (slime-draw-connection-list)) + (with-current-buffer (get-buffer-create "*SLIME connections*") + (slime-draw-connection-list) + (slime-connection-list-mode) + (setq buffer-read-only t) + (setq slime-temp-buffer-saved-window-configuration + (current-window-configuration)) + (pop-to-buffer (current-buffer)))) + +(defun slime-update-connection-list () + "Display a list of all connections." + (interactive) + (let ((pos (point)) + (inhibit-read-only t)) + (erase-buffer) + (slime-draw-connection-list) + (goto-char pos))) (defun slime-draw-connection-list () - (let ((default-pos nil)) - (slime-with-output-to-temp-buffer "*SLIME connections*" - (slime-connection-list-mode) - (let ((default (slime-connection)) - (fstring "%s%2s %-7s %-17s %-7s %-s\n")) - (insert - (format fstring " " "Nr" "Name" "Port" "Pid" "Type") - (format fstring " " "--" "----" "----" "---" "----")) - (dolist (p (reverse slime-net-processes)) - (when (eq default p) (setf default-pos (point))) - (slime-insert-propertized - (list 'slime-connection p) - (format fstring - (if (eq default p) "*" " ") - (slime-connection-number p) - (slime-lisp-implementation-type-name p) - (or (process-id p) (process-contact p)) - (slime-pid p) - (slime-lisp-implementation-type p)))))) - (with-current-buffer "*SLIME connections*" - (goto-char default-pos)))) + (let ((default-pos nil) + (default (slime-connection)) + (fstring "%s%2s %-7s %-17s %-7s %-s\n")) + (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type") + (format fstring " " "--" "----" "----" "---" "----")) + (dolist (p (reverse slime-net-processes)) + (when (eq default p) (setf default-pos (point))) + (slime-insert-propertized + (list 'slime-connection p) + (format fstring + (if (eq default p) "*" " ") + (slime-connection-number p) + (slime-lisp-implementation-type-name p) + (or (process-id p) (process-contact p)) + (slime-pid p) + (slime-lisp-implementation-type p)))) + (goto-char default-pos))) ;;; Inspector @@ -4852,6 +4871,7 @@ (defvar slime-inspector-mark-stack '()) (defun slime-inspect (string) + "Eval an expression and inspect the result." (interactive (list (slime-read-from-minibuffer "Inspect value (evaluated): " (slime-sexp-at-point)))) @@ -4885,9 +4905,8 @@ (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" " [" (fontify label "type:") " " (fontify type type) "]\n" - " " - (fontify type primitive-type) - "\n" "\n" + " [" (fontify type primitive-type) "]\n" + "\n" (fontify label "Slots") ":\n") (save-excursion (loop for (label . value) in parts @@ -5387,7 +5406,7 @@ "Lookup the argument list for FUNCTION-NAME. Confirm that EXPECTED-ARGLIST is displayed." '(("swank:start-server" - "(swank:start-server port-file)") + "(swank:start-server port-file &optional (background *swank-in-background*) dont-close)") ("swank::compound-prefix-match" "(swank::compound-prefix-match prefix target)") ("swank::create-socket" @@ -5398,6 +5417,8 @@ "(swank::compile-string-for-emacs string &key buffer position)") ("swank::connection.socket-io" "(swank::connection.socket-io structure)") + ("cl:lisp-implementation-type" + "(cl:lisp-implementation-type)") ) ;; Different arglists found in the wild. ;; ("cl:class-name" From heller at common-lisp.net Thu Mar 4 22:21:56 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 04 Mar 2004 17:21:56 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25729 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Mar 4 17:21:55 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.279 slime/ChangeLog:1.280 --- slime/ChangeLog:1.279 Wed Mar 3 15:57:46 2004 +++ slime/ChangeLog Thu Mar 4 17:21:55 2004 @@ -1,3 +1,27 @@ +2004-03-04 Helmut Eller + + * slime.el (slime-display-comletion-list): New function. Set + syntax table properly. + (slime-complete-symbol*, slime-simple-complete-symbol): Use it. + (slime-update-connection-list): New function. + (slime-draw-connection-list): Simplified. + (slime-connection-list-mode-map): Bind g to update-connection-list. + (slime-open-inspector): Print the primitive type in brackets. + (slime-test-arglist): Add test for empty arglist. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-sbcl.lisp, swank-backend.lisp + (thread-alive-p): Add default implementation. + (describe-primitive-type): Add default implementation. + (inspected-parts): Implemented for Allegro and CLISP. + + * swank.lisp (remove-dead-threads): New function. + (lookup-thread): Use it. + (print-arglist): New function. This time without a custom pretty + print dispatch table. + (format-arglist): Use it. + (inspected-parts): Add method for hash-tables. + 2004-03-03 Helmut Eller * swank.lisp: Use *emacs-connection*, *active-threads*, and From HRLTOARSOFXDRE at ascom.de Fri Mar 5 01:39:52 2004 From: HRLTOARSOFXDRE at ascom.de (Sebastian Weiss) Date: Fri, 05 Mar 2004 04:39:52 +0300 Subject: [slime-cvs] don't miss out on that great job - get your university degree now! Message-ID: An HTML attachment was scrubbed... URL: From mbaringer at common-lisp.net Fri Mar 5 14:26:15 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Fri, 05 Mar 2004 09:26:15 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el slime/swank-allegro.lisp slime/swank-clisp.lisp slime/swank-cmucl.lisp slime/swank-lispworks.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31073 Modified Files: ChangeLog slime.el swank-allegro.lisp swank-clisp.lisp swank-cmucl.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp swank.lisp Log Message: See ChangeLog entry 2004-03-05 Marco Baringer Date: Fri Mar 5 09:26:14 2004 Author: mbaringer Index: slime/ChangeLog diff -u slime/ChangeLog:1.280 slime/ChangeLog:1.281 --- slime/ChangeLog:1.280 Thu Mar 4 17:21:55 2004 +++ slime/ChangeLog Fri Mar 5 09:26:13 2004 @@ -1,3 +1,17 @@ +2004-03-05 Marco Baringer + + * swank.lisp (frame-locals-for-emacs): New function. + + * slime.el (sldb-frame-locals): Use swank::frame-locals-for-emacs + not swank::frame-locals. + (sldb-insert-locals): use the :value property, not the + :value-string property. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-sbcl.lisp (frame-locals): Return lisp + objects, not strings. Use the :value property and not the + :value-string property. + 2004-03-04 Helmut Eller * slime.el (slime-display-comletion-list): New function. Set Index: slime/slime.el diff -u slime/slime.el:1.227 slime/slime.el:1.228 --- slime/slime.el:1.227 Thu Mar 4 17:19:26 2004 +++ slime/slime.el Fri Mar 5 09:26:13 2004 @@ -4623,7 +4623,7 @@ (sldb-sugar-move 'sldb-down)) (defun sldb-frame-locals (frame) - (slime-eval `(swank:frame-locals ,frame))) + (slime-eval `(swank::frame-locals-for-emacs ,frame))) (defun sldb-insert-locals (frame prefix) (dolist (l (sldb-frame-locals frame)) @@ -4632,7 +4632,7 @@ (unless (zerop id) (insert (in-sldb-face local-name (format "#%d" id))))) (insert " = " - (in-sldb-face local-value (plist-get l :value-string)) + (in-sldb-face local-value (plist-get l :value)) "\n"))) (defun sldb-list-locals () Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.18 slime/swank-allegro.lisp:1.19 --- slime/swank-allegro.lisp:1.18 Thu Mar 4 17:15:40 2004 +++ slime/swank-allegro.lisp Fri Mar 5 09:26:14 2004 @@ -156,10 +156,9 @@ (defimplementation frame-locals (index) (let ((frame (nth-frame index))) (loop for i from 0 below (debugger:frame-number-vars frame) - collect (list :name (to-string (debugger:frame-var-name frame i)) + collect (list :name (debugger:frame-var-name frame i) :id 0 - :value-string - (to-string (debugger:frame-var-value frame i)))))) + :value (debugger:frame-var-value frame i))))) (defimplementation frame-catch-tags (index) (declare (ignore index)) Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.23 slime/swank-clisp.lisp:1.24 --- slime/swank-clisp.lisp:1.23 Thu Mar 4 17:15:40 2004 +++ slime/swank-clisp.lisp Fri Mar 5 09:26:14 2004 @@ -281,13 +281,12 @@ (loop for i from 1 below (length venv) by 2 as symbol = (svref venv (1- i)) and value = (svref venv i) - collect (list :name (to-string symbol) :id 0 - :value-string (to-string - (if (eq sys::specdecl value) - ;; special variable - (sys::eval-at frame symbol) - ;; lexical variable or symbol macro - value))))) + collect (list :name symbol :id 0 + :value (if (eq sys::specdecl value) + ;; special variable + (sys::eval-at frame symbol) + ;; lexical variable or symbol macro + value)))) (defun frame-do-fenv (frame fenv) (declare (ignore frame fenv)) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.76 slime/swank-cmucl.lisp:1.77 --- slime/swank-cmucl.lisp:1.76 Thu Mar 4 17:15:40 2004 +++ slime/swank-cmucl.lisp Fri Mar 5 09:26:14 2004 @@ -1030,11 +1030,11 @@ (loop for v across debug-variables collect (list :name (to-string (di:debug-variable-symbol v)) :id (di:debug-variable-id v) - :value-string (ecase (di:debug-variable-validity v location) - (:valid - (to-string (di:debug-variable-value v frame))) - ((:invalid :unknown) - "")))))) + :value (ecase (di:debug-variable-validity v location) + (:valid + (di:debug-variable-value v frame)) + ((:invalid :unknown) + "")))))) (defimplementation frame-catch-tags (index) (loop for (tag . code-location) in (di:frame-catches (nth-frame index)) Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.27 slime/swank-lispworks.lisp:1.28 --- slime/swank-lispworks.lisp:1.27 Thu Mar 4 17:15:40 2004 +++ slime/swank-lispworks.lisp Fri Mar 5 09:26:14 2004 @@ -230,9 +230,8 @@ (mapcar (lambda (var) (destructuring-bind (name value symbol location) var (declare (ignore name location)) - (list :name (to-string symbol) :id 0 - :value-string - (to-string value)))) + (list :name symbol :id 0 + :value value))) vars))))) (defimplementation frame-catch-tags (index) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.67 slime/swank-openmcl.lisp:1.68 --- slime/swank-openmcl.lisp:1.67 Wed Mar 3 15:55:38 2004 +++ slime/swank-openmcl.lisp Fri Mar 5 09:26:14 2004 @@ -335,9 +335,9 @@ (declare (ignore type)) (when name (push (list - :name (to-string name) + :name name :id 0 - :value-string (to-string var)) + :value var) result)))) (return-from frame-locals (nreverse result)))))))) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.72 slime/swank-sbcl.lisp:1.73 --- slime/swank-sbcl.lisp:1.72 Thu Mar 4 17:15:40 2004 +++ slime/swank-sbcl.lisp Fri Mar 5 09:26:14 2004 @@ -585,13 +585,12 @@ (declare (type (or null simple-vector) debug-variables)) (loop for v across debug-variables collect (list - :name (to-string (sb-di:debug-var-symbol v)) + :name (sb-di:debug-var-symbol v) :id (sb-di:debug-var-id v) - :value-string - (if (eq (sb-di:debug-var-validity v location) - :valid) - (to-string (sb-di:debug-var-value v frame)) - ""))))) + :value (if (eq (sb-di:debug-var-validity v location) + :valid) + (sb-di:debug-var-value v frame) + ""))))) (defimplementation frame-catch-tags (index) (loop for (tag . code-location) in (sb-di:frame-catches (nth-frame index)) Index: slime/swank.lisp diff -u slime/swank.lisp:1.135 slime/swank.lisp:1.136 --- slime/swank.lisp:1.135 Thu Mar 4 17:12:44 2004 +++ slime/swank.lisp Fri Mar 5 09:26:14 2004 @@ -859,6 +859,17 @@ (defslimefun eval-string-in-frame (string index) (to-string (eval-in-frame (from-string string) index))) +(defun frame-locals-for-emacs (frame-index) + (mapcar (lambda (frame-locals) + (loop + for (key value) on frame-locals by #'cddr + collect key + if (member key (list :name :value)) + collect (to-string value) + else + collect value)) + (frame-locals frame-index))) + ;;;; Evaluation From heller at common-lisp.net Fri Mar 5 22:51:13 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 05 Mar 2004 17:51:13 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28749 Modified Files: swank.lisp Log Message: (frame-locals-for-emacs): Bind *print-readably* to nil. Date: Fri Mar 5 17:51:13 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.136 slime/swank.lisp:1.137 --- slime/swank.lisp:1.136 Fri Mar 5 09:26:14 2004 +++ slime/swank.lisp Fri Mar 5 17:51:12 2004 @@ -860,15 +860,14 @@ (to-string (eval-in-frame (from-string string) index))) (defun frame-locals-for-emacs (frame-index) - (mapcar (lambda (frame-locals) - (loop - for (key value) on frame-locals by #'cddr - collect key - if (member key (list :name :value)) - collect (to-string value) - else - collect value)) - (frame-locals frame-index))) + (let ((*print-readably* nil) + (*print-pretty* t) + (*print-circle* t)) + (mapcar (lambda (frame-locals) + (destructuring-bind (&key name id value) frame-locals + (list :name (princ-to-string name) :id id + :value (to-string value)))) + (frame-locals frame-index)))) ;;;; Evaluation From heller at common-lisp.net Fri Mar 5 22:53:34 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 05 Mar 2004 17:53:34 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7072 Modified Files: swank-lispworks.lisp Log Message: (getpid, emacs-connected): Conditionalize for Windows. Patch from Bill Clementson. Date: Fri Mar 5 17:53:34 2004 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.28 slime/swank-lispworks.lisp:1.29 --- slime/swank-lispworks.lisp:1.28 Fri Mar 5 09:26:14 2004 +++ slime/swank-lispworks.lisp Fri Mar 5 17:53:34 2004 @@ -58,6 +58,7 @@ (defimplementation emacs-connected () ;; Set SIGINT handler on Swank request handler thread. + #-win32 (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*))) ;;; Unix signals @@ -74,8 +75,9 @@ (defmethod call-without-interrupts (fn) (lispworks:without-interrupts (funcall fn))) -(defmethod getpid () - (system::getpid)) +(defimplementation getpid () + #+win32 (win32:get-current-process-id) + #-win32 (system::getpid)) (defimplementation lisp-implementation-type-name () "lispworks") @@ -219,10 +221,7 @@ (invoke-restart-interactively (nth-restart index))) (defimplementation frame-locals (n) - (let ((frame (nth-frame n)) - (*print-readably* nil) - (*print-pretty* t) - (*print-circle* t)) + (let ((frame (nth-frame n))) (if (dbg::call-frame-p frame) (destructuring-bind (vars with) (dbg::frame-locals-format-list frame #'list 75 0) From heller at common-lisp.net Fri Mar 5 22:55:49 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 05 Mar 2004 17:55:49 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25741 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Mar 5 17:55:49 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.281 slime/ChangeLog:1.282 --- slime/ChangeLog:1.281 Fri Mar 5 09:26:13 2004 +++ slime/ChangeLog Fri Mar 5 17:55:49 2004 @@ -1,3 +1,13 @@ +2004-03-05 Bill Clementson + + * swank-lispworks.lisp (getpid, emacs-connected): Conditionalize + for Windows. + +2004-03-05 Helmut Eller + + * swank.lisp (frame-locals-for-emacs): Bind *print-readably* to + nil. + 2004-03-05 Marco Baringer * swank.lisp (frame-locals-for-emacs): New function. From heller at common-lisp.net Sun Mar 7 16:40:18 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 07 Mar 2004 11:40:18 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12217 Modified Files: slime.el Log Message: Patch by Jouni K Seppanen: (sldb-help-summary): New function. (sldb-mode): Add docstring so that describe-mode is useful. (sldb-mode-map): Add bindings for sldb-help-summary and describe-mode. (define-sldb-invoke-restart-key): Generate docstrings. (sldb-default-action/mouse, sldb-default-action) (sldb-eval-in-frame, sldb-pprint-eval-in-frame) (sldb-inspect-in-frame, sldb-down, sldb-up, sldb-details-up) (sldb-details-down, sldb-list-locals, sldb-quit, sldb-continue) (sldb-abort, sldb-invoke-restart, sldb-break-with-default-debugger) (sldb-step): Add rudimentary docstrings. (slime-complete-symbol*, slime-simple-complete-symbol): Use the correct block name when returning. (slime-display-completion-list): Fix typo. Date: Sun Mar 7 11:40:18 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.228 slime/slime.el:1.229 --- slime/slime.el:1.228 Fri Mar 5 09:26:13 2004 +++ slime/slime.el Sun Mar 7 11:40:18 2004 @@ -3262,12 +3262,12 @@ (interactive) (funcall slime-complete-symbol-function)) -(defun slime-complete-symbol* () +(defun* slime-complete-symbol* () "Expand abbreviations and complete the symbol at point." ;; NB: It is only the name part of the symbol that we actually want ;; to complete -- the package prefix, if given, is just context. (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) - (return-from slime-complete-symbol (comint-dynamic-complete-as-filename))) + (return-from slime-complete-symbol* (comint-dynamic-complete-as-filename))) (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) (beg (move-marker (make-marker) (slime-symbol-start-pos))) (prefix (buffer-substring-no-properties beg end)) @@ -3297,10 +3297,10 @@ (length completed-prefix))))) (goto-char (+ beg unambiguous-completion-length)) (slime-complete-maybe-save-window-configuration) - (slime-display-comletion-list completion-set) + (slime-display-completion-list completion-set) (slime-complete-delay-restoration))))))) -(defun slime-display-comletion-list (completion-list) +(defun slime-display-completion-list (completion-list) (with-output-to-temp-buffer "*Completions*" (display-completion-list completion-set) (with-current-buffer standard-output @@ -3310,7 +3310,8 @@ "Complete the symbol at point. Perform completion more similar to Emacs' complete-symbol." (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) - (return-from slime-complete-symbol (comint-dynamic-complete-as-filename))) + (return-from slime-simple-complete-symbol + (comint-dynamic-complete-as-filename))) (let* ((end (point)) (beg (slime-symbol-start-pos)) (prefix (buffer-substring-no-properties beg end))) @@ -3329,7 +3330,7 @@ (t (slime-minibuffer-respecting-message "Complete but not unique") (slime-complete-maybe-save-window-configuration) - (slime-display-comletion-list completion-set) + (slime-display-completion-list completion-set) (slime-complete-delay-restoration))))))) (defun slime-minibuffer-respecting-message (format &rest format-args) @@ -4222,7 +4223,38 @@ ;;;;; sldb-mode (define-derived-mode sldb-mode fundamental-mode "sldb" - "Superior lisp debugger mode + "Superior lisp debugger mode. In addition to ordinary SLIME commands, +the following are available:\\ + +Commands to examine the selected frame: + \\[sldb-toggle-details] - toggle details (local bindings, CATCH tags) + \\[sldb-show-source] - view source for the frame + \\[sldb-eval-in-frame] - eval in frame + \\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result + \\[sldb-disassemble] - disassemble + \\[sldb-inspect-in-frame] - inspect + \\[sldb-list-locals] - list locals + +Commands to invoke restarts: + \\[sldb-quit] - quit + \\[sldb-abort] - abort + \\[sldb-continue] - continue + \\[sldb-invoke-restart-0]-\\[sldb-invoke-restart-9] - restart shortcuts + +Commands to navigate frames: + \\[sldb-down] - down + \\[sldb-up] - up + \\[sldb-details-down] - down, with details + \\[sldb-details-up] - up, with details + +Miscellaneous commands: + \\[sldb-restart-frame] - restart frame + \\[sldb-return-from-frame] - return from frame + \\[sldb-step] - step + \\[sldb-break-with-default-debugger] - break + \\[slime-interactive-eval] - eval + +Full list of commands: \\{sldb-mode-map}" (erase-buffer) @@ -4233,7 +4265,35 @@ (make-local-variable 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'sldb-delete-overlays)) +(defun sldb-help-summary () + "Show summary of important sldb commands" + (interactive) + (message + (mapconcat + #'(lambda (list) + (let* ((cmd (first list)) + (letter (second list)) + (name (third list)) + (name-with-letter (fourth list)) + (where-is (where-is-internal cmd sldb-mode-map))) + (if (or (member (vector (intern letter)) where-is) + (member (vector (string-to-char letter)) where-is)) + name-with-letter + (substitute-command-keys + (format "\\\\[%s] %s" cmd name))))) + '((sldb-down "n" "next" "n-ext") + (sldb-up "p" "prev" "p-rev") + (sldb-toggle-details "t" "toggle details" "t-oggle details") + (sldb-eval-in-frame "e" "eval" "e-val") + (sldb-continue "c" "continue" "c-ontinue") + (sldb-abort "a" "abort" "a-bort") + (sldb-show-source "v" "view source" "v-iew source") + (describe-mode "h" "help" "h-elp")) + ", "))) + (slime-define-keys sldb-mode-map + ("?" 'sldb-help-summary) + ("h" 'describe-mode) ("v" 'sldb-show-source) ((kbd "RET") 'sldb-default-action) ("\C-m" 'sldb-default-action) @@ -4266,9 +4326,11 @@ ;; Keys 0-9 are shortcuts to invoke particular restarts. (defmacro define-sldb-invoke-restart-key (number key) - (let ((fname (intern (format "sldb-invoke-restart-%S" number)))) + (let ((fname (intern (format "sldb-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) `(progn (defun ,fname () + ,docstring (interactive) (sldb-invoke-restart ,number)) (define-key sldb-mode-map ,key ',fname)))) @@ -4421,6 +4483,7 @@ ;;;;; SLDB commands (defun sldb-default-action/mouse (event) + "Invoke the action pointed at by the mouse." (interactive "e") (destructuring-bind (mouse-1 (w pos &rest _)) event (save-excursion @@ -4429,6 +4492,7 @@ (if fn (funcall fn)))))) (defun sldb-default-action () + "Invoke the action at point." (interactive) (let ((fn (get-text-property (point) 'sldb-default-action))) (if fn (funcall fn)))) @@ -4560,6 +4624,7 @@ (defun sldb-eval-in-frame (string) + "Prompt for an expression and evaluate it in the selected frame." (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) (let* ((number (sldb-frame-number-at-point))) (slime-eval-async `(swank:eval-string-in-frame ,string ,number) @@ -4567,6 +4632,7 @@ (lambda (reply) (slime-message "==> %s" reply))))) (defun sldb-pprint-eval-in-frame (string) + "Prompt for an expression, evaluate in selected frame, pretty-print result." (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) (let* ((number (sldb-frame-number-at-point))) (slime-eval-async `(swank:pprint-eval-string-in-frame ,string ,number) @@ -4575,6 +4641,7 @@ (slime-show-description result nil))))) (defun sldb-inspect-in-frame (string) + "Prompt for an expression and inspect it in the selected frame." (interactive (list (slime-read-from-minibuffer "Inspect in frame (evaluated): " (slime-sexp-at-point)))) @@ -4597,10 +4664,12 @@ nil sldb-backtrace-start-marker))) (defun sldb-down () + "Select next frame." (interactive) (sldb-forward-frame)) (defun sldb-up () + "Select previous frame." (interactive) (sldb-backward-frame) (when (= (point) sldb-backtrace-start-marker) @@ -4615,10 +4684,12 @@ (sldb-show-source))) (defun sldb-details-up () + "Select previous frame and show details." (interactive) (sldb-sugar-move 'sldb-up)) (defun sldb-details-down () + "Select next frame and show details." (interactive) (sldb-sugar-move 'sldb-down)) @@ -4636,6 +4707,7 @@ "\n"))) (defun sldb-list-locals () + "List local variables in selected frame." (interactive) (let ((frame (sldb-frame-number-at-point))) (slime-message "%s" (with-temp-buffer @@ -4651,10 +4723,12 @@ (defun sldb-quit () + "Quit to toplevel." (interactive) (slime-eval-async '(swank:throw-to-toplevel) nil (lambda (_)))) (defun sldb-continue () + "Invoke the \"continue\" restart." (interactive) (slime-rex () ('(swank::sldb-continue)) @@ -4664,10 +4738,14 @@ ((:abort) ))) (defun sldb-abort () + "Invoke the \"abort\" restart." (interactive) (slime-eval-async '(swank:sldb-abort) nil (lambda ()))) (defun sldb-invoke-restart (&optional number) + "Invoke a restart. +Optional NUMBER specifies the restart to invoke, otherwise +use the restart at point." (interactive) (let ((restart (or number (sldb-restart-at-point)))) (slime-rex () @@ -4680,12 +4758,14 @@ (error "No restart at point"))) (defun sldb-break-with-default-debugger () + "Enter default debugger." (interactive) (slime-rex () ('(swank:sldb-break-with-default-debugger) nil slime-current-thread) ((:abort)))) (defun sldb-step () + "Select the \"continue\" restart and set a new break point." (interactive) (let ((frame (sldb-frame-number-at-point))) (slime-eval-async `(swank:sldb-step ,frame) nil (lambda ())))) From heller at common-lisp.net Sun Mar 7 16:41:13 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 07 Mar 2004 11:41:13 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13271 Modified Files: swank-cmucl.lisp Log Message: (frame-locals): Use #:not-available instead of "". Date: Sun Mar 7 11:41:13 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.77 slime/swank-cmucl.lisp:1.78 --- slime/swank-cmucl.lisp:1.77 Fri Mar 5 09:26:14 2004 +++ slime/swank-cmucl.lisp Sun Mar 7 11:41:11 2004 @@ -1034,7 +1034,7 @@ (:valid (di:debug-variable-value v frame)) ((:invalid :unknown) - "")))))) + '#:not-available)))))) (defimplementation frame-catch-tags (index) (loop for (tag . code-location) in (di:frame-catches (nth-frame index)) From heller at common-lisp.net Sun Mar 7 16:42:08 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 07 Mar 2004 11:42:08 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19884 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Mar 7 11:42:08 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.282 slime/ChangeLog:1.283 --- slime/ChangeLog:1.282 Fri Mar 5 17:55:49 2004 +++ slime/ChangeLog Sun Mar 7 11:42:08 2004 @@ -1,3 +1,26 @@ +2004-03-07 Jouni K Seppanen + + * slime.el (sldb-help-summary): New function. + (sldb-mode): Add docstring so that describe-mode is useful. + (sldb-mode-map): Add bindings for sldb-help-summary and + describe-mode. + (define-sldb-invoke-restart-key): Generate docstrings. + (sldb-default-action/mouse, sldb-default-action) + (sldb-eval-in-frame, sldb-pprint-eval-in-frame) + (sldb-inspect-in-frame, sldb-down, sldb-up, sldb-details-up) + (sldb-details-down, sldb-list-locals, sldb-quit, sldb-continue) + (sldb-abort, sldb-invoke-restart, sldb-break-with-default-debugger) + (sldb-step): Add rudimentary docstrings. + +2004-03-07 Helmut Eller + + * slime.el (slime-complete-symbol*, slime-simple-complete-symbol): + Use the correct block name when returning. + (slime-display-completion-list): Fix typo. + + * swank-cmucl.lisp (frame-locals): Use #:not-available instead of + "". + 2004-03-05 Bill Clementson * swank-lispworks.lisp (getpid, emacs-connected): Conditionalize From heller at common-lisp.net Mon Mar 8 07:14:58 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 08 Mar 2004 02:14:58 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30074 Modified Files: slime.el Log Message: (slime-start-swank-server, slime-maybe-start-lisp): Translate filenames. Reported by "49gu4n502 at sneakemail.com". (slime-insert-balanced-comments slime-remove-balanced-comments) (slime-pretty-lambdas): New functions. From Bill Clementson. Date: Mon Mar 8 02:14:58 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.229 slime/slime.el:1.230 --- slime/slime.el:1.229 Sun Mar 7 11:40:18 2004 +++ slime/slime.el Mon Mar 8 02:14:57 2004 @@ -965,7 +965,8 @@ (call-interactively 'inferior-lisp) (comint-send-string (inferior-lisp-proc) (format "(load %S)\n" - (concat slime-path slime-backend))) + (slime-to-lisp-filename + (concat slime-path slime-backend)))) (slime-maybe-start-multiprocessing))) (defun slime-maybe-start-multiprocessing () @@ -977,7 +978,8 @@ "Start a Swank server on the inferior lisp." (comint-send-string (inferior-lisp-proc) (format "(swank:start-server %S)\n" - (slime-swank-port-file)))) + (slime-to-lisp-filename + (slime-swank-port-file))))) (defun slime-swank-port-file () "Filename where the SWANK server writes its TCP port number." @@ -5204,6 +5206,47 @@ (skip-chars-forward " \t\n)") (skip-chars-backward " \t\n") (delete-region point (point))))) + +(defun slime-insert-balanced-comments (arg) + "Insert a set of balanced comments around the s-expression +containing the point. If this command is invoked repeatedly +(without any other command occurring between invocations), the +comment progressively moves outward over enclosing expressions. +If invoked with a positive prefix argument, the s-expression arg +expressions out is enclosed in a set of balanced comments." + (interactive "*p") + (save-excursion + (when (eq last-command this-command) + (when (search-backward "#|" nil t) + (save-excursion + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + (while (> arg 0) + (backward-char 1) + (cond ((looking-at ")") (incf arg)) + ((looking-at "(") (decf arg)))) + (insert "#|") + (forward-sexp) + (insert "|#"))) + +(defun slime-remove-balanced-comments () + "Remove a set of balanced comments enclosing point." + (interactive "*") + (save-excursion + (when (search-backward "#|" nil t) + (delete-char 2) + (while (and (< (point) (point-max)) (not (looking-at " *|#"))) + (forward-sexp)) + (replace-match "")))) + +(defun slime-pretty-lambdas () + (font-lock-add-keywords + nil `(("(\\(lambda\\>\\)" + (0 (progn (compose-region (match-beginning 1) (match-end 1) + ,(make-char 'greek-iso8859-7 107)) + nil)))))) ;;; Test suite From heller at common-lisp.net Mon Mar 8 07:15:42 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 08 Mar 2004 02:15:42 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2116 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Mar 8 02:15:41 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.283 slime/ChangeLog:1.284 --- slime/ChangeLog:1.283 Sun Mar 7 11:42:08 2004 +++ slime/ChangeLog Mon Mar 8 02:15:41 2004 @@ -1,3 +1,14 @@ +2004-03-08 Helmut Eller + + * slime.el (slime-start-swank-server, slime-maybe-start-lisp): + Translate filenames. + +2004-03-08 Bill Clementson + + * slime.el (slime-insert-balanced-comments) + (slime-remove-balanced-comments, slime-pretty-lambdas): New + functions. + 2004-03-07 Jouni K Seppanen * slime.el (sldb-help-summary): New function. From heller at common-lisp.net Mon Mar 8 23:45:19 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 08 Mar 2004 18:45:19 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12032 Modified Files: swank-cmucl.lisp Log Message: (read-into-simple-string): Use the correct fix. Reported by H?kon Alstadheim. Date: Mon Mar 8 18:45:19 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.78 slime/swank-cmucl.lisp:1.79 --- slime/swank-cmucl.lisp:1.78 Sun Mar 7 11:41:11 2004 +++ slime/swank-cmucl.lisp Mon Mar 8 18:45:19 2004 @@ -24,10 +24,17 @@ :format-control "Trying to read characters from a binary stream.")) ;; Let's go as low level as it seems reasonable. (let* ((numbytes (- end start)) - (bytes-read (system:read-n-bytes stream s start numbytes t))) - (if (< bytes-read numbytes) - (+ start bytes-read) - end))) + (total-bytes 0)) + ;; read-n-bytes may return fewer bytes than requested, so we need + ;; to keep trying. + (loop while (plusp numbytes) do + (let ((bytes-read (system:read-n-bytes stream s start numbytes nil))) + (when (zerop bytes-read) + (return-from read-into-simple-string total-bytes)) + (incf total-bytes bytes-read) + (incf start bytes-read) + (decf numbytes bytes-read))) + total-bytes)) (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp))) (when s From heller at common-lisp.net Mon Mar 8 23:47:00 2004 From: heller at common-lisp.net (Helmut Eller) Date: Mon, 08 Mar 2004 18:47:00 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23427 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Mar 8 18:47:00 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.284 slime/ChangeLog:1.285 --- slime/ChangeLog:1.284 Mon Mar 8 02:15:41 2004 +++ slime/ChangeLog Mon Mar 8 18:46:59 2004 @@ -1,7 +1,12 @@ +2004-03-09 Helmut Eller + + * swank-cmucl.lisp (read-into-simple-string): Use the correct fix. + Reported by H?kon Alstadheim. + 2004-03-08 Helmut Eller * slime.el (slime-start-swank-server, slime-maybe-start-lisp): - Translate filenames. + Translate filenames. Reported by Dan Muller. 2004-03-08 Bill Clementson From heller at common-lisp.net Tue Mar 9 08:32:10 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 09 Mar 2004 03:32:10 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23679 Modified Files: Tag: package-split slime.el Log Message: (slime-symbol-at-point, slime-symbol-name-at-point): slime-symbol-at-point calls slime-symbol-name-at-point not the other way around. This avoids the mess if the symbol at point is NIL. (slime-compile-file, slime-load-system, slime-compile-region) (slime-call-describer, slime-who-calls, sldb-catch-tags): Updates for renamed lisp functions. (slime-list-callers, slime-list-callees): Unified with other xref commands. (sldb-show-frame-details): Catch tags no longer include the source location. (sldb-insert-locals): Simplified. Date: Tue Mar 9 03:32:09 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.230 slime/slime.el:1.230.2.1 --- slime/slime.el:1.230 Mon Mar 8 02:14:57 2004 +++ slime/slime.el Tue Mar 9 03:32:09 2004 @@ -780,18 +780,18 @@ (beginning-of-defun) (buffer-substring-no-properties (point) end)))) -(defun slime-symbol-at-point () - "Return the symbol at point, otherwise nil." +(defun slime-symbol-name-at-point () + "Return the name of the symbol at point, otherwise nil." (save-excursion (skip-syntax-forward "w_") (skip-syntax-backward "-") (let ((string (thing-at-point 'symbol))) - (if string (intern (substring-no-properties string)) nil)))) + (substring-no-properties string)))) -(defun slime-symbol-name-at-point () - "Return the name of the symbol at point, otherwise nil." - (let ((sym (slime-symbol-at-point))) - (and sym (symbol-name sym)))) +(defun slime-symbol-at-point () + "Return the symbol at point, otherwise nil." + (let ((name (slime-symbol-at-point))) + (and name (intern name)))) (defun slime-sexp-at-point () "Return the sexp at point, otherwise nil." @@ -2321,7 +2321,7 @@ (format "Compile file %s" lisp-filename)) (slime-display-output-buffer) (slime-eval-async - `(swank:swank-compile-file ,lisp-filename ,(if load t nil)) + `(swank:compile-file-for-emacs ,lisp-filename ,(if load t nil)) nil (slime-compilation-finished-continuation)) (message "Compiling %s.." lisp-filename))) @@ -2346,7 +2346,7 @@ (save-some-buffers) (slime-display-output-buffer) (slime-eval-async - `(swank:swank-load-system ,system-name) + `(swank:load-system-for-emacs ,system-name) nil (slime-compilation-finished-continuation)) (message "Compiling system %s.." system-name)) @@ -2370,7 +2370,7 @@ (defun slime-compile-string (string start-offset) (slime-eval-async - `(swank:swank-compile-string ,string ,(buffer-name) ,start-offset) + `(swank:compile-string-for-emacs ,string ,(buffer-name) ,start-offset) (slime-buffer-package) (slime-compilation-finished-continuation))) @@ -3768,6 +3768,7 @@ (princ string))) (defun slime-describe-symbol (symbol-name) + "Describe the symbol at point." (interactive (list (slime-read-symbol-name "Describe symbol: "))) (when (not symbol-name) (error "No symbol given")) @@ -3884,7 +3885,7 @@ (defun slime-call-describer (item) (let ((type (get-text-property (point) 'type))) - (slime-eval-describe `(swank:describe-definition ,item ,type)))) + (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type)))) ;;; XREF: cross-referencing @@ -3994,37 +3995,47 @@ (defun slime-who-calls (symbol) "Show all known callers of the function SYMBOL." (interactive (list (slime-read-symbol-name "Who calls: " t))) - (slime-xref 'calls symbol)) + (slime-xref :calls symbol)) (defun slime-who-references (symbol) "Show all known referrers of the global variable SYMBOL." (interactive (list (slime-read-symbol-name "Who references: " t))) - (slime-xref 'references symbol)) + (slime-xref :references symbol)) (defun slime-who-binds (symbol) "Show all known binders of the global variable SYMBOL." (interactive (list (slime-read-symbol-name "Who binds: " t))) - (slime-xref 'binds symbol)) + (slime-xref :binds symbol)) (defun slime-who-sets (symbol) "Show all known setters of the global variable SYMBOL." (interactive (list (slime-read-symbol-name "Who sets: " t))) - (slime-xref 'sets symbol)) + (slime-xref :sets symbol)) (defun slime-who-macroexpands (symbol) "Show all known expanders of the macro SYMBOL." (interactive (list (slime-read-symbol-name "Who macroexpands: " t))) - (slime-xref 'macroexpands symbol)) + (slime-xref :macroexpands symbol)) (defun slime-who-specializes (symbol) "Show all known methods specialized on class SYMBOL." (interactive (list (slime-read-symbol-name "Who specializes: " t))) - (slime-xref 'specializes symbol)) + (slime-xref :specializes symbol)) + +(defun slime-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callers: "))) + (slime-xref :callers symbol-name)) + +(defun slime-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window." + (interactive (list (slime-read-symbol-name "List callees: "))) + (slime-xref :callees symbol-name)) (defun slime-xref (type symbol) "Make an XREF request to Lisp." (slime-eval-async - `(,(intern (format "swank:who-%s" type)) ',symbol) + `(swank:xref ',type ',symbol) (slime-buffer-package t) (lexical-let ((type type) (symbol symbol) @@ -4095,31 +4106,6 @@ (kill-buffer buffer))) -;;; List callers/callees - -(defun slime-eval-show-function-list (form type name) - "Eval FROM in Lisp and display the result in a xref window." - (ring-insert-at-beginning slime-find-definition-history-ring (point-marker)) - (lexical-let ((package (slime-buffer-package)) - (name name) - (type type)) - (slime-eval-async form package - (lambda (result) - (slime-show-xrefs result type name package))))) - -(defun slime-list-callers (symbol-name) - "List the callers of SYMBOL-NAME in a xref window." - (interactive (list (slime-read-symbol-name "List callers: "))) - (slime-eval-show-function-list `(swank:list-callers ,symbol-name) - 'callers symbol-name)) - -(defun slime-list-callees (symbol-name) - "List the callees of SYMBOL-NAME in a xref window." - (interactive (list (slime-read-symbol-name "List callees: "))) - (slime-eval-show-function-list `(swank:list-callees ,symbol-name) - 'callees symbol-name)) - - ;;; Macroexpansion (defun slime-eval-macroexpand (expander) @@ -4587,11 +4573,11 @@ (in-sldb-face catch-tag "[No catch-tags]\n"))) (t (insert indent1 "Catch-tags:\n") - (loop for (tag . location) in catchers - do (slime-insert-propertized - '(catch-tag ,tag) - indent2 (in-sldb-face catch-tag - (format "%S\n" tag)))))))) + (dolist (tag catchers) + (slime-insert-propertized + '(catch-tag ,tag) + indent2 (in-sldb-face catch-tag + (format "%S\n" tag)))))))) (unless sldb-enable-styled-backtrace (terpri)) (point))))) @@ -4699,14 +4685,12 @@ (slime-eval `(swank::frame-locals-for-emacs ,frame))) (defun sldb-insert-locals (frame prefix) - (dolist (l (sldb-frame-locals frame)) - (insert prefix (in-sldb-face local-name (plist-get l :name))) - (let ((id (plist-get l :id))) + (dolist (var (sldb-frame-locals frame)) + (destructuring-bind (&key name id value) var + (insert prefix (in-sldb-face local-name name)) (unless (zerop id) - (insert (in-sldb-face local-name (format "#%d" id))))) - (insert " = " - (in-sldb-face local-value (plist-get l :value)) - "\n"))) + (insert (in-sldb-face local-name (format "#%d" id)))) + (insert " = " (in-sldb-face local-value value) "\n")))) (defun sldb-list-locals () "List local variables in selected frame." @@ -4717,7 +4701,7 @@ (buffer-string))))) (defun sldb-catch-tags (frame) - (slime-eval `(swank:frame-catch-tags ,frame))) + (slime-eval `(swank:frame-catch-tags-for-emacs ,frame))) (defun sldb-list-catch-tags () (interactive) @@ -5537,7 +5521,7 @@ ("swank::emacs-connected" "(swank::emacs-connected)") ("swank::compile-string-for-emacs" - "(swank::compile-string-for-emacs string &key buffer position)") + "(swank::compile-string-for-emacs string buffer position)") ("swank::connection.socket-io" "(swank::connection.socket-io structure)") ("cl:lisp-implementation-type" From heller at common-lisp.net Tue Mar 9 08:46:50 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 09 Mar 2004 03:46:50 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5126 Modified Files: Tag: package-split swank.lisp Log Message: (:swank): Create the package here. (*swank-in-background*): Call the backend function preferred-communication-style to for the initial value. (find-symbol-designator): Handle NIL properly. (arglist-string): Renamed from format-arglist. Call backend function directly. (*sldb-restarts*, swank-debugger-hook, format-restarts-for-emacs) (nth-restart, invoke-nth-restart, sldb-abort): Handle restarts in the front end. (frame-for-emacs): Renamed from print-with-frame-label. (backtrace, debugger-info-for-emacs, pprint-eval-string-in-frame) (set-default-directory): Now in the front end. (frame-locals-for-emacs): Use print not princ for variable names. (compile-file-for-emacs, compile-string-for-emacs): Small wrappers around backend functions. (describe-definition-for-emacs): Handle unknown symbols before calling the backend. (find-function-locations): Wrapper for new backend function find-definitions. (group-xrefs, partition, location-valid-p, xref-buffer, xref): Updated for the new backend functions. Date: Tue Mar 9 03:46:50 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.137 slime/swank.lisp:1.137.2.1 --- slime/swank.lisp:1.137 Fri Mar 5 17:51:12 2004 +++ slime/swank.lisp Tue Mar 9 03:46:50 2004 @@ -7,12 +7,13 @@ ;;; This code has been placed in the Public Domain. All warranties are ;;; disclaimed. -;;; Currently the package is declared in swank-backend.lisp -#+nil (defpackage :swank - (:use :common-lisp) - (:export #:start-server #:create-swank-server - #:*sldb-pprint-frames*)) + (:use :common-lisp :swank-backend) + (:export #:*sldb-pprint-frames* + #:start-server + #:create-swank-server + #:ed-in-emacs + )) (in-package :swank) @@ -51,6 +52,13 @@ (defun missing-arg () (error "A required &KEY or &OPTIONAL argument was not supplied.")) +(defun package-external-symbols (package) + (let ((list '())) + (do-external-symbols (sym package) (push sym list)) + list)) + +;; (package-external-symbols (find-package :swank)) + ;;;; Connections ;;; @@ -152,7 +160,7 @@ Redirection is done while Lisp is processing a request for Emacs.") (defvar *use-dedicated-output-stream* t) -(defvar *swank-in-background* nil) +(defvar *swank-in-background* (preferred-communication-style)) (defvar *log-events* nil) (defun start-server (port-file &optional (background *swank-in-background*) @@ -706,10 +714,10 @@ (t (let ((package (or (find-package package-name) default-package))) (multiple-value-bind (symbol access) (find-symbol name package) - (cond ((and symbol package-name (not internal-p) + (cond ((and package-name (not internal-p) (not (eq access :external))) (values nil nil)) - (symbol (values symbol access))))))))) + (access (values symbol access))))))))) (defun find-symbol-or-lose (string &optional (default-package *buffer-package*)) @@ -720,18 +728,14 @@ (cond (package (values symbol package)) (t (error "Unknown symbol: ~S [in ~A]" string default-package))))) -(defun format-arglist (function-name lambda-list-fn) - "Use LAMBDA-LIST-FN to format the arglist for FUNCTION-NAME. -Call LAMBDA-LIST-FN with the symbol corresponding to FUNCTION-NAME." - (declare (type function lambda-list-fn)) +(defslimefun arglist-string (name) (multiple-value-bind (arglist condition) - (ignore-errors - (let ((symbol (find-symbol-or-lose function-name))) - (values (funcall lambda-list-fn symbol)))) + (ignore-errors (values (arglist (find-symbol-or-lose name)))) (cond (condition (format nil "(-- ~A)" condition)) - (t (if (null arglist) - "()" - (print-arglist-to-string arglist)))))) + (t (etypecase arglist + (string arglist) + (null "()") + (cons (print-arglist-to-string arglist))))))) (defun print-arglist-to-string (arglist) (with-output-to-string (*standard-output*) @@ -776,6 +780,8 @@ (defvar *sldb-initial-frames* 20 "The initial number of backtrace frames to send to Emacs.") +(defvar *sldb-restarts*) + (defun swank-debugger-hook (condition hook) "Debugger entry point, called from *DEBUGGER-HOOK*. Sends a message to Emacs declaring that the debugger has been entered, @@ -783,11 +789,13 @@ after Emacs causes a restart to be invoked." (declare (ignore hook)) (let ((*swank-debugger-condition* condition) + (*sldb-restarts* (compute-restarts condition)) (*package* (or (and (boundp '*buffer-package*) (symbol-value '*buffer-package*)) *package*)) (*sldb-level* (1+ *sldb-level*)) - (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))) + (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)) + (*print-readably* nil)) (force-user-output) (call-with-debugging-environment (lambda () (sldb-loop *sldb-level*))))) @@ -834,18 +842,66 @@ (format nil " [Condition of type ~S]" (type-of *swank-debugger-condition*)))) -(defun print-with-frame-label (n fn) - "Bind some printer variables to properly indent the frame and call -FN with a string-stream for printing a frame of a bracktrace. Return -the string." - (declare (type function fn)) +(defun format-restarts-for-emacs () + "Return a list of restarts for *swank-debugger-condition* in a +format suitable for Emacs." + (loop for restart in *sldb-restarts* + collect (list (princ-to-string (restart-name restart)) + (princ-to-string restart)))) + +(defun frame-for-emacs (n frame) (let* ((label (format nil " ~D: " n)) (string (with-output-to-string (stream) (let ((*print-pretty* *sldb-pprint-frames*) (*print-circle* t)) - (princ label stream) (funcall fn stream))))) + (princ label stream) + (print-frame frame stream))))) (subseq string (length label)))) +(defslimefun backtrace (start end) + (loop for frame in (compute-backtrace start end) + for i from start + collect (list i (frame-for-emacs i frame)))) + +(defslimefun debugger-info-for-emacs (start end) + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition ({restart}*) ({stack-frame}*) +where + condition ::= (description type) + restart ::= (name description) + stack-frame ::= (number description) + +condition---a pair of strings: message, and type. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + ((\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0).\" + \"[Condition of type DIVISION-BY-ZERO]\") + ((\"ABORT\" \"Return to Slime toplevel.\") + (\"ABORT\" \"Return to Top-Level.\")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))" + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace start end))) + +(defun nth-restart (index) + (nth index *sldb-restarts*)) + +(defslimefun invoke-nth-restart (index) + (invoke-restart-interactively (nth-restart index))) + +(defslimefun sldb-abort () + (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + (defslimefun sldb-continue () (continue)) @@ -859,16 +915,24 @@ (defslimefun eval-string-in-frame (string index) (to-string (eval-in-frame (from-string string) index))) -(defun frame-locals-for-emacs (frame-index) +(defslimefun pprint-eval-string-in-frame (string index) + (swank-pprint + (multiple-value-list + (eval-in-frame index (from-string string))))) + +(defslimefun frame-locals-for-emacs (frame-index) (let ((*print-readably* nil) (*print-pretty* t) (*print-circle* t)) (mapcar (lambda (frame-locals) (destructuring-bind (&key name id value) frame-locals - (list :name (princ-to-string name) :id id + (list :name (to-string name) :id id :value (to-string value)))) (frame-locals frame-index)))) +(defslimefun frame-catch-tags-for-emacs (frame-index) + (frame-catch-tags frame-index)) + ;;;; Evaluation @@ -987,6 +1051,10 @@ (let ((p (setq *package* (guess-package-from-string package)))) (list (package-name p) (shortest-package-nickname p)))) +(defslimefun set-default-directory (directory) + (setf *default-pathname-defaults* (merge-pathnames directory)) + (namestring *default-pathname-defaults*)) + (defslimefun listener-eval (string) (clear-user-input) (multiple-value-bind (values last-form) (eval-region string t) @@ -1052,22 +1120,23 @@ (list (to-string result) (format nil "~,2F" (/ usecs 1000000.0))))) -(defslimefun swank-compile-file (filename load-p) +(defslimefun compile-file-for-emacs (filename load-p) "Compile FILENAME and, when LOAD-P, load the result. Record compiler notes signalled as `compiler-condition's." - (swank-compiler (lambda () (compile-file-for-emacs filename load-p)))) + (swank-compiler (lambda () (swank-compile-file filename load-p)))) -(defslimefun swank-compile-string (string buffer position) +(defslimefun compile-string-for-emacs (string buffer position) "Compile STRING (exerpted from BUFFER at POSITION). Record compiler notes signalled as `compiler-condition's." (swank-compiler (lambda () - (compile-string-for-emacs string :buffer buffer :position position)))) + (let ((*package* *buffer-package*)) + (swank-compile-string string :buffer buffer :position position))))) (defslimefun swank-load-system (system) "Compile and load SYSTEM using ASDF. Record compiler notes signalled as `compiler-condition's." - (swank-compiler (lambda () (compile-system-for-emacs system)))) + (swank-compiler (lambda () (swank-compile-system system)))) ;;;; Macroexpansion @@ -1082,12 +1151,13 @@ (defslimefun swank-macroexpand (string) (apply-macro-expander #'macroexpand string)) -(defslimefun disassemble-symbol (symbol-name) - (print-output-to-string (lambda () (disassemble (from-string symbol-name))))) - (defslimefun swank-macroexpand-all (string) (apply-macro-expander #'macroexpand-all string)) +(defslimefun disassemble-symbol (symbol-name) + (with-output-to-string (*standard-output*) + (disassemble (find-symbol-or-lose symbol-name)))) + ;;;; Completion @@ -1333,25 +1403,26 @@ (not (symbol-external-p sym))))) (apropos-list string package))) -(defun print-output-to-string (fn) - (declare (type function fn)) +(defun describe-to-string (object) (with-output-to-string (*standard-output*) - (let ((*debug-io* *standard-output*)) - (funcall fn)))) - -(defun print-description-to-string (object) - (print-output-to-string (lambda () (describe object)))) + (describe object))) (defslimefun describe-symbol (symbol-name) - (multiple-value-bind (symbol foundp) - (find-symbol-designator symbol-name) - (cond (foundp (print-description-to-string symbol)) - (t (format nil "Unknown symbol: ~S [in ~A]" - symbol-name *buffer-package*))))) + (describe-to-string (find-symbol-or-lose symbol-name))) (defslimefun describe-function (symbol-name) - (print-description-to-string - (symbol-function (find-symbol-designator symbol-name)))) + (let ((symbol (find-symbol-or-lose symbol-name))) + (describe-to-string (or (macro-function symbol) + (symbol-function symbol))))) + +(defslimefun describe-definition-for-emacs (symbol-name kind) + (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name) + (cond (foundp + (with-output-to-string (*standard-output*) + (describe-definition symbol kind))) + (t + (format nil "Unknown symbol: ~S [in ~A]" + symbol-name *buffer-package*))))) (defslimefun documentation-symbol (symbol-name &optional default) (let ((*package* *buffer-package*)) @@ -1414,14 +1485,20 @@ ;;;; Source Locations -(defstruct (:location (:type list) :named - (:constructor make-location (buffer position))) - buffer position) - -(defstruct (:error (:type list) :named (:constructor)) message) -(defstruct (:file (:type list) :named (:constructor)) name) -(defstruct (:buffer (:type list) :named (:constructor)) name) -(defstruct (:position (:type list) :named (:constructor)) pos) +(defslimefun find-function-locations (symbol-name) + "Return a list of source-locations for SYMBOL-NAME's functions." + (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name) + (cond ((not foundp) + (list (list :error (format nil "Unkown symbol: ~A" symbol-name)))) + ((macro-function symbol) + (mapcar #'second (find-definitions symbol))) + ((special-operator-p symbol) + (list (list :error (format nil "~A is a special-operator" symbol)))) + ((fboundp symbol) + (mapcar #'second (find-definitions symbol))) + (t (list (list :error + (format nil "Symbol not fbound: ~A" symbol-name))))))) + (defun alistify (list key test) "Partition the elements of LIST into an alist. KEY extracts the key @@ -1442,27 +1519,59 @@ (position-pos pos2))) (t nil))) -(defun partition (list predicate) - (declare (type function predicate)) +(defun partition (list test key) + (declare (type function test key)) (loop for e in list - if (funcall predicate e) collect e into yes + if (funcall test (funcall key e)) collect e into yes else collect e into no finally (return (values yes no)))) +(defstruct (xref (:conc-name xref.) + (:type list)) + dspec location) + +(defun location-valid-p (location) + (eq (car location) :location)) + +(defun xref-buffer (xref) + (location-buffer (xref.location xref))) + +(defun xref-position (xref) + (location-buffer (xref.location xref))) + (defun group-xrefs (xrefs) - (flet ((xref-buffer (xref) (location-buffer (cdr xref))) - (xref-position (xref) (location-position (cdr xref)))) - (multiple-value-bind (resolved errors) - (partition xrefs (lambda (x) (location-p (cdr x)))) - (let ((alist (alistify resolved #'xref-buffer #'equal))) - (append - (loop for (key . list) in alist - collect (cons (to-string key) - (sort list #'location-position< - :key #'xref-position))) - (if errors - `(("Unresolved" . ,errors)))))))) + (multiple-value-bind (resolved errors) + (partition xrefs #'location-valid-p #'xref.location) + (let ((alist (alistify resolved #'xref-buffer #'equal))) + (append + (loop for (buffer . list) in alist + collect (cons (second buffer) + (mapcar (lambda (xref) + (cons (to-string (xref.dspec xref)) + (xref.location xref))) + (sort list #'location-position< + :key #'xref-position)))) + (if errors + (list (cons "Unresolved" + (mapcar (lambda (xref) + (cons (to-string (xref.dspec xref)) + (xref.location xref))) + errors)))))))) + +(defslimefun xref (type symbol-name) + (let ((symbol (find-symbol-or-lose symbol-name))) + (group-xrefs + (ecase type + (:calls (who-calls symbol)) + (:references (who-references symbol)) + (:binds (who-binds symbol)) + (:sets (who-sets symbol)) + (:macroexpands (who-macroexpands symbol)) + (:specializes (who-specializes symbol)) + (:callers (list-callers symbol)) + (:callees (list-callees symbol)))))) +; (xref :calls "to-string") ;;;; Inspecting @@ -1532,7 +1641,7 @@ (defslimefun describe-inspectee () "Describe the currently inspected object." - (print-description-to-string *inspectee*)) + (describe-to-string *inspectee*)) (defmethod inspected-parts ((object cons)) (if (consp (cdr object)) From heller at common-lisp.net Tue Mar 9 08:55:14 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 09 Mar 2004 03:55:14 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7840 Modified Files: Tag: package-split swank-backend.lisp Log Message: (:swank-backend): New package. (definterface): Export the symbol. (:location, :error, :position, :buffer): Define structure of source locations here. (preferred-communication-style, compute-backtrace, print-frame): New functions. (debugger-info-for-emacs): Deleted. Renaming: compile-file-for-emacs -> swank-compile-file compile-string-for-emacs -> swank-compile-string compile-system-for-emacs -> swank-compile-stystem arglist-string -> arglist backrace -> compute-backtrace find-function-locations -> find-definitions Date: Tue Mar 9 03:55:14 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.35 slime/swank-backend.lisp:1.35.2.1 --- slime/swank-backend.lisp:1.35 Thu Mar 4 17:15:39 2004 +++ slime/swank-backend.lisp Tue Mar 9 03:55:14 2004 @@ -8,105 +8,25 @@ ;;; separately for each Lisp. Each is declared as a generic function ;;; for which swank-.lisp provides methods. -(defpackage :swank +(defpackage :swank-backend (:use :common-lisp) - (:nicknames #:swank-backend) - (:export #:*sldb-pprint-frames* - #:apropos-list-for-emacs - #:arglist-string - #:backtrace - #:call-with-I/O-lock - #:call-with-conversation-lock - #:compiler-notes-for-emacs - #:completions - #:create-server - #:create-swank-server - #:describe-definition - #:describe-symbol - #:describe-symbol-for-emacs - #:describe-function - #:disassemble-symbol - #:documentation-symbol - #:eval-in-frame - #:return-from-frame - #:restart-frame - #:eval-string - #:eval-string-in-frame - #:oneway-eval-string - #:find-function-locations - #:frame-catch-tags - #:frame-locals - #:frame-source-location-for-emacs - #:frame-source-position - #:lisp-implementation-type-name - #:getpid - #:connection-info - #:give-goahead - #:give-gohead - #:init-inspector - #:inspect-in-frame - #:inspect-nth-part - #:inspector-next - #:inspector-pop - #:describe-inspectee - #:interactive-eval - #:interactive-eval-region - #:invoke-nth-restart - #:invoke-nth-restart-for-emacs - #:list-all-package-names - #:list-callees - #:list-callers - #:listener-eval - #:load-file - #:pprint-eval - #:pprint-eval-string-in-frame - #:quit-inspector - #:re-evaluate-defvar - #:set-default-directory - #:set-package - #:sldb-abort - #:sldb-break-with-default-debugger - #:sldb-continue - #:sldb-disassemble - #:sldb-step - #:slime-debugger-function - #:debugger-info-for-emacs - #:start-server - #:startup-multiprocessing - #:swank-compile-file - #:swank-compile-string - #:swank-load-system - #:swank-macroexpand - #:swank-macroexpand-1 - #:swank-macroexpand-all - #:take-input - #:thread-id - #:thread-name - #:throw-to-toplevel - #:toggle-trace-fdefinition - #:untrace-all - #:profile - #:unprofile - #:unprofile-all - #:profiled-functions - #:profile-report - #:profile-reset - #:profile-package - #:toggle-profile-fdefinition - #:wait-goahead - #:warn-unimplemented-interfaces - #:who-binds - #:who-calls - #:who-macroexpands - #:who-references - #:who-sets - #:who-specializes - #:list-threads - #:quit-thread-browser - #:ed-in-emacs + (:export #:sldb-condition + #:original-condition + #:compiler-condition + #:message + #:short-message + #:condition + #:severity + #:location + #:location-p + #:location-buffer + #:location-position + #:position-p + #:position-pos + #:print-output-to-string )) -(in-package :swank) +(in-package :swank-backend) ;;;; Metacode @@ -134,12 +54,13 @@ &rest ,received-args) (destructuring-bind ,args ,received-args , at default-body))))) - `(progn (defgeneric ,name ,args (:documentation ,documentation)) - (pushnew ',name *interface-functions*) - ,(if (null default-body) - `(pushnew ',name *unimplemented-interfaces*) - (gen-default-impl)) - ',name))) + ` (progn (defgeneric ,name ,args (:documentation ,documentation)) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + (export ',name :swank-backend) + ',name))) (defmacro defimplementation (name args &body body) ;; Is this a macro no-no -- should it be pushed out of macroexpansion? @@ -184,6 +105,10 @@ (definterface remove-fd-handlers (socket) "Remove all fd-handlers for SOCKET.") +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + ;;; Base condition for networking errors. (define-condition network-error (error) ()) @@ -201,8 +126,9 @@ (defconstant +sigint+ 2) -(defgeneric call-without-interrupts (fn) - (:documentation "Call FN in a context where interrupts are disabled.")) +(definterface call-without-interrupts (fn) + "Call FN in a context where interrupts are disabled." + (funcall fn)) (definterface getpid () "Return the (Unix) process ID of this superior Lisp.") @@ -221,7 +147,7 @@ (declare (ignore ignore)) `(call-with-compilation-hooks (lambda () (progn , at body)))) -(definterface compile-string-for-emacs (string &key buffer position) +(definterface swank-compile-string (string &key buffer position) "Compile source from STRING. During compilation, compiler conditions must be trapped and resignalled as COMPILER-CONDITIONs. @@ -230,7 +156,7 @@ Additionally, if POSITION is supplied, it must be added to source positions reported in compiler conditions.") -(definterface compile-system-for-emacs (system-name) +(definterface swank-compile-system (system-name) "Compile and load SYSTEM-NAME, During compilation compiler conditions must be trapped and resignalled as COMPILER-CONDITION ala compile-string-for-emacs." @@ -241,7 +167,7 @@ (funcall operate load-op system-name))) (t (error "ASDF not loaded"))))) -(definterface compile-file-for-emacs (filename load-p) +(definterface swank-compile-file (filename load-p) "Compile FILENAME signalling COMPILE-CONDITIONs. If LOAD-P is true, load the file after compilation.") @@ -289,9 +215,12 @@ ;;;; Documentation -(definterface arglist-string (function-name) - "Return the argument for FUNCTION-NAME as a string. -The result should begin and end with parenthesis.") +(definterface arglist (name) + "Return the lambda list for the symbol NAME. + +The result can be a list or a string. + +An error should be signaled if the lambda list cannot be found.") (definterface macroexpand-all (form) "Recursively expand all macros in FORM. @@ -351,54 +280,18 @@ user without (re)entering the debugger by wrapping them as `sldb-condition's.")) -(definterface debugger-info-for-emacs (start end) - "Return debugger state, with stack frames from START to END. -The result is a list: - (condition ({restart}*) ({stack-frame}*) -where - condition ::= (description type) - restart ::= (name description) - stack-frame ::= (number description) - -condition---a pair of strings: message, and type. - -restart---a pair of strings: restart name, and description. - -stack-frame---a number from zero (the top), and a printed -representation of the frame's call. - -Below is an example return value. In this case the condition was a -division by zero (multi-line description), and only one frame is being -fetched (start=0, end=1). - - ((\"Arithmetic error DIVISION-BY-ZERO signalled. -Operation was KERNEL::DIVISION, operands (1 0).\" - \"[Condition of type DIVISION-BY-ZERO]\") - ((\"ABORT\" \"Return to Slime toplevel.\") - (\"ABORT\" \"Return to Top-Level.\")) - ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))") - -(definterface backtrace (start end) +(definterface compute-backtrace (start end) "Return a list containing a backtrace of the condition current being debugged. The results are unspecified if this function is -called outside the dynamic contour of a debugger hook defined by -DEFINE-DEBUGGER-HOOK. +called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") -START and END are zero-based indices constraining the number of -frames returned. Frame zero is defined as the frame which invoked -the debugger. - -The backtrace is returned as a list of tuples of the form -\(FRAME-NUMBER FRAME-DESCRIPTION), where FRAME-NUMBER is the -index of the frame, defined like START/END, and FRAME-DESCRIPTION -is a string containing text to display in the debugger for this -frame. - -An example return value: - - ((0 \"(HELLO \"world\")\") - (1 \"(RUN-EXCITING-LISP-DEMO)\") - (2 \"(SYS::%TOPLEVEL #)\"))") +(definterface print-frame (frame stream) + "Print frame to stream.") (definterface frame-source-location-for-emacs (frame-number) "Return the source location for FRAME-NUMBER.") @@ -441,6 +334,69 @@ as it was called originally.") +;;;; Definition finding + +(defstruct (:location (:type list) :named + (:constructor make-location (buffer position))) + buffer position) + +(defstruct (:error (:type list) :named (:constructor)) message) +(defstruct (:file (:type list) :named (:constructor)) name) +(defstruct (:buffer (:type list) :named (:constructor)) name) +(defstruct (:position (:type list) :named (:constructor)) pos) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is string denoting a symbol or \"definition specifier\". + +DSPEC is a symbol or a \"definition specifier\" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +\(DEFVAR BAR).") + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...).") + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value.") + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value.") + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value.") + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value.") + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value.") + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + ;;;; Profiling ;;; The following functions define a minimal profiling interface. @@ -478,50 +434,6 @@ themselves, that is, their dispatch functions, are left alone.") -;;;; Queries - -#+(or) -;;; This is probably a better interface than find-function-locations. -(definterface find-definitions (name) - "Return a list of (LABEL . LOCATION) pairs for NAME's definitions. - -NAME is string denoting a symbol or \"definition specifier\". - -LABEL is a string describing the definition, e.g., \"foo\" or -\"(method foo (string number))\" or \"(variable bar)\". - -LOCATION is a source location of the form: - - ::= (:location ) - | (:error ) - - ::= (:file ) - | (:buffer ) - | (:source-form ) - - ::= (:position []) ; 1 based - | (:function-name ) -") - -(definterface find-function-locations (name) - "Return a list (LOCATION LOCATION ...) for NAME's definitions. - -LOCATION is a source location of the form: - - ::= (:location ) - | (:error ) - - ::= (:file ) - | (:buffer ) - | (:source-form ) - - ::= (:position []) ; 1 based - | (:line []) - | (:function-name ) - | (:source-path ) -") - - ;;;; Inspector (definterface inspected-parts (object) @@ -530,10 +442,11 @@ (definterface describe-primitive-type (object) "Return a string describing the primitive type of object." + (declare (ignore object)) "N/A") -;;;; Multiprocessing +;;;; Multithreading ;;; ;;; The default implementations are sufficient for non-multiprocessing ;;; implementations. @@ -599,51 +512,3 @@ (definterface receive () "Return the next message from current thread's mailbox.") - - -;;;; XREF - -(definterface who-calls (function-name) - "Return the call sites of FUNCTION-NAME (a string). -The results are grouped together by filename: - ::= (*) - ::= ( . (*)) - ::= (