From heller at common-lisp.net Fri Oct 1 11:59:24 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 01 Oct 2004 13:59:24 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31454 Modified Files: slime.el Log Message: (slime-set-connection-info): Hide the *inferior-lisp* after we now Lisp's pid. (slime-find-buffer-package): We need to preserve the case for things like (:in-package "foo"), so return "\"foo\"". Date: Fri Oct 1 13:59:24 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.404 slime/slime.el:1.405 --- slime/slime.el:1.404 Tue Sep 28 00:21:50 2004 +++ slime/slime.el Fri Oct 1 13:59:24 2004 @@ -433,9 +433,12 @@ (defun slime-pretty-package-name (name) "Return a pretty version of a package name designator (as a string)." - (cond ((string-match "^:\\(.*\\)$" name) (match-string 1 name)) - ((string-match "^\"\\(.*\\)\"$" name) (match-string 1 name)) - (t name))) + (let ((name (cond ((string-match "^:\\(.*\\)$" name) + (match-string 1 name)) + ((string-match "^\"\\(.*\\)\"$" name) + (match-string 1 name)) + (t name)))) + (format "%s" (read name)))) (when slime-update-modeline-package (run-with-idle-timer 0.2 0.2 'slime-update-modeline-package)) @@ -1181,7 +1184,6 @@ (slime-dispatching-connection process)) (message "Initial handshake...") (slime-setup-connection process) - (slime-hide-inferior-lisp-buffer) (message "Connected. %s" (slime-random-words-of-encouragement)))) (defun slime-start-and-load (filename &optional package) @@ -1219,7 +1221,7 @@ ,(format "Start up slime according to `%s'." progsym) (interactive) (let ((inferior-lisp-program ,progsym)) - (run-hook ',hooksym) + (run-hooks ',hooksym) (call-interactively 'slime)))))) ;;;;; Start inferior lisp @@ -1374,7 +1376,8 @@ (defun slime-hide-inferior-lisp-buffer () "Display the REPL buffer instead of the *inferior-lisp* buffer." - (let* ((buffer (if (slime-process) (process-buffer (slime-process)))) + (let* ((buffer (if (slime-process) + (process-buffer (slime-process)))) (window (if buffer (get-buffer-window buffer))) (repl (slime-output-buffer t))) (when buffer @@ -1764,6 +1767,7 @@ (slime-connection-name) (slime-generate-connection-name name) (slime-lisp-features) features)) (setq slime-state-name "") ; FIXME + (slime-hide-inferior-lisp-buffer) (slime-init-output-buffer connection) (run-hooks 'slime-connected-hook)) @@ -1945,7 +1949,7 @@ (goto-char (match-end 0)) (skip-chars-forward " \n\t\f\r#") (let ((pkg (ignore-errors (read (current-buffer))))) - (if pkg (format "%s" pkg)))))) + (if pkg (format "%S" pkg)))))) ;;; Synchronous requests is implemented in terms of asynchronous ;;; ones. We make an asynchronous request with a continuation function From heller at common-lisp.net Fri Oct 1 12:02:30 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 01 Oct 2004 14:02:30 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32395 Modified Files: swank.lisp Log Message: (parse-symbol): Don't use the reader because to avoid interning unknown symbols. The downside is that we no longer handle escaped |symbols| correctly. Date: Fri Oct 1 14:02:29 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.244 slime/swank.lisp:1.245 --- slime/swank.lisp:1.244 Tue Sep 28 00:23:01 2004 +++ slime/swank.lisp Fri Oct 1 14:02:29 2004 @@ -962,17 +962,37 @@ (let ((*read-suppress* nil)) (read-from-string string)))) -;;; FIXME! FOO::BAR will intern FOO in BAR. +;; FIXME: deal with #\| etc. hard to do portably. +(defun tokenize-symbol (string) + (let ((package (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (search "::" string))) + (values symbol package internp))) + +;; FIXME: Escape chars are ignored +(defun casify (string) + "Convert string accoring to readtable-case." + (ecase (readtable-case *readtable*) + (:preserve + string) + (:upcase + (string-upcase string)) + (:downcase + (string-downcase string)) + (:invert + (multiple-value-bind (lower upper) (determine-case string) + (cond ((and lower upper) string) + (lower (string-upcase string)) + (upper (string-downcase string)) + (t string)))))) + (defun parse-symbol (string &optional (package *package*)) "Find the symbol named STRING. Return the symbol and a flag indicateing if the symbols was found." - (multiple-value-bind (sym pos) (let ((*package* keyword-package)) - (ignore-errors (read-from-string string))) - (if (and (symbolp sym) (eql (length string) pos)) - (if (find #\: string) - (find-symbol (string sym) (symbol-package sym)) - (find-symbol (string sym) package)) - (values nil nil)))) + (multiple-value-bind (sname pname) (tokenize-symbol string) + (find-symbol (casify sname) (if pname (casify pname) package)))) (defun parse-symbol-or-lose (string &optional (package *package*)) (multiple-value-bind (symbol status) (parse-symbol string package) @@ -980,6 +1000,7 @@ (values symbol status) (error "Unknown symbol: ~A [in ~A]" string package)))) +;; FIXME: interns the name (defun parse-package (string) "Find the package named STRING. Return the package or nil." @@ -1729,17 +1750,10 @@ PACKAGE, the package to complete in INTERNAL-P, if the symbol is qualified with `::'." (multiple-value-bind (name package-name internal-p) - (tokenize-symbol-designator string) + (tokenize-symbol string) (let ((package (carefully-find-package package-name default-package-name))) (values name package-name package internal-p)))) -(defun tokenize-symbol-designator (string) - (values (let ((pos (position #\: string :from-end t))) - (if pos (subseq string (1+ pos)) string)) - (let ((pos (position #\: string))) - (if pos (subseq string 0 pos) nil)) - (search "::" string))) - (defun carefully-find-package (name default-package-name) "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the *buffer-package*. NAME and DEFAULT-PACKAGE-NAME can be nil." @@ -2861,7 +2875,7 @@ (when (eq package (symbol-package sym)) (push sym internal-symbols) (multiple-value-bind (symbol status) - (intern (symbol-name sym) package) + (find-symbol (symbol-name sym) package) (declare (ignore symbol)) (when (eql :external status) (push sym external-symbols))))) @@ -3011,6 +3025,8 @@ (defun inspector-content-for-emacs (spec) (loop for part in spec collect (etypecase part + (null ; XXX encourages sloppy programming + nil) (string part) (cons (destructure-case part ((:newline) @@ -3156,8 +3172,6 @@ (mop-helper symbol #'swank-mop:class-direct-subclasses)) (:superclasses (mop-helper symbol #'swank-mop:class-direct-superclasses))))) - - ;;;; Automatically synchronized state From heller at common-lisp.net Fri Oct 1 12:05:08 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 01 Oct 2004 14:05:08 +0200 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32426 Modified Files: swank-cmucl.lisp Log Message: (code-component-entry-points): Only include entry points with "valid" functions names. This excludes internal lambdas, which have usually have usually a string as name, like "defun foo". Date: Fri Oct 1 14:05:08 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.121 slime/swank-cmucl.lisp:1.122 --- slime/swank-cmucl.lisp:1.121 Thu Sep 23 23:33:51 2004 +++ slime/swank-cmucl.lisp Fri Oct 1 14:05:08 2004 @@ -565,13 +565,13 @@ (defun code-component-entry-points (code) "Return a list ((NAME LOCATION) ...) of function definitons for the code omponent CODE." - (delete-duplicates - (loop for e = (kernel:%code-entry-points code) - then (kernel::%function-next e) - while e - collect (list (kernel:%function-name e) - (function-location e))) - :test #'equal)) + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (ext:valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) (defimplementation list-callers (symbol) "Return a list ((NAME LOCATION) ...) of callers." From heller at common-lisp.net Fri Oct 1 12:16:45 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 01 Oct 2004 14:16:45 +0200 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv901 Modified Files: swank-allegro.lisp Log Message: (find-fspec-location): excl:source-file can return stuff like (:operator ...); try to handle it. Date: Fri Oct 1 14:16:44 2004 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.59 slime/swank-allegro.lisp:1.60 --- slime/swank-allegro.lisp:1.59 Fri Sep 17 14:48:39 2004 +++ slime/swank-allegro.lisp Fri Oct 1 14:16:44 2004 @@ -2,7 +2,7 @@ ;;; ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. ;;; -;;; Created 2003, Helmut Eller +;;; Created 2003 ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. This code was written for "Allegro CL Trial @@ -29,51 +29,9 @@ ;;; swank-mop -;; maybe better change MOP to ACLMOP ? -(import-to-swank-mop - '( ;; classes - cl:standard-generic-function - mop::standard-slot-definition - cl:method - cl:standard-class - mop:eql-specializer - ;; standard-class readers - mop:class-default-initargs - mop:class-direct-default-initargs - mop:class-direct-slots - mop:class-direct-subclasses - mop:class-direct-superclasses - mop:class-finalized-p - cl:class-name - mop:class-precedence-list - mop:class-prototype - mop:class-slots - mop:specializer-direct-methods - ;; eql-specializer accessors - mop:eql-specializer-object - ;; generic function readers - mop:generic-function-argument-precedence-order - mop:generic-function-declarations - mop:generic-function-lambda-list - mop:generic-function-methods - mop:generic-function-method-class - mop:generic-function-method-combination - mop:generic-function-name - ;; method readers - mop:method-generic-function - mop:method-function - mop:method-lambda-list - mop:method-specializers - excl::method-qualifiers - ;; slot readers - mop:slot-definition-allocation - mop:slot-definition-initargs - mop:slot-definition-initform - mop:slot-definition-initfunction - mop:slot-definition-name - mop:slot-definition-type - mop:slot-definition-readers - mop:slot-definition-writers)) +;; maybe better change MOP to ACLMOP ? +;; CLOS also works in ACL5. --he +(import-swank-mop-symbols :clos '(:slot-definition-documentation)) (defun swank-mop:slot-definition-documentation (slot) (documentation slot)) @@ -316,29 +274,43 @@ (symbol (string fspec)) (list (string (second fspec))))) +(defun find-definition-in-file (fspec type file) + (let* ((start (scm:find-definition-in-file fspec type file)) + (pos (if start + (list :position (1+ start)) + (list :function-name (fspec-primary-name fspec))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-definition-in-buffer (filename) + (let ((pos (position #\; filename :from-end t))) + (make-location + (list :buffer (subseq filename 0 pos)) + (list :position (parse-integer (subseq filename (1+ pos))))))) + (defun find-fspec-location (fspec type) (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type)) (etypecase file (pathname - (let* ((start (scm:find-definition-in-file fspec type file)) - (pos (if start - (list :position (1+ start)) - (list :function-name (fspec-primary-name fspec))))) - (make-location (list :file (namestring (truename file))) - pos))) + (find-definition-in-file fspec type file)) ((member :top-level) (list :error (format nil "Defined at toplevel: ~A" (fspec->string fspec)))) (string - (let ((pos (position #\; file :from-end t))) - (make-location - (list :buffer (subseq file 0 pos)) - (list :position (parse-integer (subseq file (1+ pos))))))) + (find-definition-in-buffer file)) (null (list :error (if err (princ-to-string err) (format nil "Unknown source location for ~A" - (fspec->string fspec)))))))) + (fspec->string fspec))))) + (cons + (destructuring-bind ((type . filename)) file + (assert (member type '(:operator))) + (etypecase filename + (pathname + (find-definition-in-file fspec type filename)) + (string + (find-definition-in-buffer filename)))))))) (defun fspec->string (fspec) (etypecase fspec @@ -447,9 +419,7 @@ `("Name: " (:value ,(function-name f)) (:newline) "Its argument list is: " ,(princ-to-string (arglist f)) (:newline) "Documentation:" (:newline) - ;; AllegroCL doesn't support (documentation t) - ;; so we get the symbol and then its doc - ,(documentation (excl::external-fn_symdef f) 'function)))) + ,(documentation f 'function)))) (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector)) (values "A structure class." @@ -486,9 +456,11 @@ `(:value ,(swank-mop:class-prototype class)) '"N/A (class not finalized)")))) -(defmethod inspect-for-emacs ((slot excl::structure-slot-definition) (inspector acl-inspector)) +#-:allegro-v5.0 +(defmethod inspect-for-emacs ((slot excl::structure-slot-definition) + (inspector acl-inspector)) (values "A structure slot." - `("Name: " (:value ,(mop:slot-definition-name slot)) + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) "Documentation:" (:newline) ,@(when (documentation slot) From heller at common-lisp.net Fri Oct 1 12:18:59 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 01 Oct 2004 14:18:59 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv983 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Oct 1 14:18:59 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.541 slime/ChangeLog:1.542 --- slime/ChangeLog:1.541 Tue Sep 28 00:39:40 2004 +++ slime/ChangeLog Fri Oct 1 14:18:59 2004 @@ -1,3 +1,21 @@ +2004-10-01 Helmut Eller + + * swank-allegro.lisp (find-fspec-location): excl:source-file can + return stuff like (:operator ...); try to handle it. + + * swank-cmucl.lisp (code-component-entry-points): Only include + entry points with "valid" functions names. This excludes internal + lambdas, which have usually a string as name, like "defun foo". + + * swank.lisp (parse-symbol): Don't use the reader to avoid + interning unknown symbols. The downside is that we no longer + handle escaped |symbols| correctly. + + * slime.el (slime-set-connection-info): Hide the *inferior-lisp* + buffer after we know Lisp's pid. + (slime-find-buffer-package): We need to preserve the case for + things like (:in-package "foo"), so return "\"foo\"". + 2004-09-27 Helmut Eller * slime.el (slime-process): New function intended to replace all From asimon at common-lisp.net Fri Oct 1 13:17:43 2004 From: asimon at common-lisp.net (Andras Simon) Date: Fri, 01 Oct 2004 15:17:43 +0200 Subject: [slime-cvs] CVS update: slime/swank-abcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5453 Modified Files: swank-abcl.lisp Log Message: Redefine BREAK. Date: Fri Oct 1 15:17:42 2004 Author: asimon Index: slime/swank-abcl.lisp diff -u slime/swank-abcl.lisp:1.19 slime/swank-abcl.lisp:1.20 --- slime/swank-abcl.lisp:1.19 Sun Sep 26 19:07:46 2004 +++ slime/swank-abcl.lisp Fri Oct 1 15:17:42 2004 @@ -15,6 +15,16 @@ (require :collect) ;just so that it doesn't spoil the flying letters (require :pprint)) +(defun sys::break (&optional (format-control "BREAK called") &rest format-arguments) + (let ((*saved-backtrace* (sys::backtrace-as-list))) + (with-simple-restart (continue "Return from BREAK.") + (invoke-debugger + (sys::%make-condition 'simple-condition + (list :format-control format-control + :format-arguments format-arguments)))) + nil)) + + (defimplementation make-fn-streams (input-fn output-fn) (let* ((output (ext:make-slime-output-stream output-fn)) (input (ext:make-slime-input-stream input-fn output))) From heller at common-lisp.net Fri Oct 1 13:29:52 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 01 Oct 2004 15:29:52 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5771 Modified Files: slime.el Log Message: (slime-set-connection-info): Print the words of encouragement here after all the other asynchronous initialization. Date: Fri Oct 1 15:29:51 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.405 slime/slime.el:1.406 --- slime/slime.el:1.405 Fri Oct 1 13:59:24 2004 +++ slime/slime.el Fri Oct 1 15:29:51 2004 @@ -1183,8 +1183,7 @@ (let* ((process (slime-net-connect host port)) (slime-dispatching-connection process)) (message "Initial handshake...") - (slime-setup-connection process) - (message "Connected. %s" (slime-random-words-of-encouragement)))) + (slime-setup-connection process))) (defun slime-start-and-load (filename &optional package) "Start Slime, if needed, load the current file and set the package." @@ -1769,7 +1768,8 @@ (setq slime-state-name "") ; FIXME (slime-hide-inferior-lisp-buffer) (slime-init-output-buffer connection) - (run-hooks 'slime-connected-hook)) + (run-hooks 'slime-connected-hook) + (message "Connected. %s" (slime-random-words-of-encouragement))) (defun slime-generate-connection-name (lisp-name) (loop for i from 1 From heller at common-lisp.net Fri Oct 1 13:39:10 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 01 Oct 2004 15:39:10 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6766 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Oct 1 15:39:10 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.542 slime/ChangeLog:1.543 --- slime/ChangeLog:1.542 Fri Oct 1 14:18:59 2004 +++ slime/ChangeLog Fri Oct 1 15:39:10 2004 @@ -10,9 +10,11 @@ * swank.lisp (parse-symbol): Don't use the reader to avoid interning unknown symbols. The downside is that we no longer handle escaped |symbols| correctly. - + * slime.el (slime-set-connection-info): Hide the *inferior-lisp* - buffer after we know Lisp's pid. + buffer after we know Lisp's pid. Print the words of encouragement + here, when all the other asynchronous initialization is completed. + (slime-find-buffer-package): We need to preserve the case for things like (:in-package "foo"), so return "\"foo\"". From heller at common-lisp.net Sun Oct 3 12:10:48 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 03 Oct 2004 14:10:48 +0200 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19352 Modified Files: swank-loader.lisp Log Message: (compile-files-if-needed-serially): Load verbosely. Date: Sun Oct 3 14:10:48 2004 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.35 slime/swank-loader.lisp:1.36 --- slime/swank-loader.lisp:1.35 Sun Sep 26 19:09:13 2004 +++ slime/swank-loader.lisp Sun Oct 3 14:10:48 2004 @@ -77,7 +77,7 @@ (ensure-directories-exist binary-pathname) (compile-file source-pathname :output-file binary-pathname) (setq needs-recompile t)) - (load binary-pathname)) + (load binary-pathname :verbose t)) #+(or) (error () ;; If an error occurs compiling, load the source instead From heller at common-lisp.net Sun Oct 3 12:25:59 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 03 Oct 2004 14:25:59 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20289 Modified Files: slime.el Log Message: Reduce dependency on inf-lisp internals. Make it possible to start the inferior lisp in a buffer different from "*inferior-lisp*". (slime): Parse the command argument explicitly and don't rely on `inferior-lisp'. Don't close all connections, but only the one for the inferior lisp buffer we are using. (slime-maybe-start-lisp): Take the command and buffer as argument. Decide here whether we should just disconnect and reconnect or start a new process. (slime-start-lisp): Load verbosely. (slime-inferior-lisp): New function. Replaces call to `inferior-lisp'. (slime-inferior-connect, slime-start-swank-server): Take the inferior process as argument (slime-read-port-and-connect): Set the slime-inferior-process variable in the new connection. (slime-inferior-process): New connection local variable. (slime-process): Use it. (slime-restart-inferior-lisp): Don't use inferior lisp stuff. (slime-switch-to-output-buffer): Process interactive arguments properly. Date: Sun Oct 3 14:25:58 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.406 slime/slime.el:1.407 --- slime/slime.el:1.406 Fri Oct 1 15:29:51 2004 +++ slime/slime.el Sun Oct 3 14:25:58 2004 @@ -1157,19 +1157,16 @@ ;;;;; Entry points -(defun slime () +(defun slime (command buffer) "Start an inferior^_superior Lisp and connect to its Swank server." - (interactive) + (interactive (list (if current-prefix-arg + (read-string "Run lisp: " inferior-lisp-program) + inferior-lisp-program) + "*inferior-lisp*")) (when (or (not (slime-bytecode-stale-p)) (slime-urge-bytecode-recompile)) - (cond ((and current-prefix-arg - (slime-connected-p) - (slime-process)) - (unless (slime-maybe-rearrange-inferior-lisp) - (slime-disconnect))) - (t (slime-disconnect))) - (slime-maybe-start-lisp) - (slime-inferior-connect))) + (let ((proc (slime-maybe-start-lisp command buffer))) + (slime-inferior-connect proc nil)))) (defun slime-connect (host port &optional kill-old-p) "Connect to a running Swank server." @@ -1291,41 +1288,63 @@ (rename-buffer (generate-new-buffer-name (buffer-name))) t))) -(defun slime-maybe-start-lisp () +(defun slime-maybe-start-lisp (command buffername) "Start an inferior lisp. Instruct it to load Swank." - (unless (get-buffer-process inferior-lisp-buffer) - (slime-start-lisp))) + (cond ((not (comint-check-proc buffername)) + (slime-start-lisp command buffername)) + ((y-or-n-p "Create an additional *inferior-lisp*? ") + (slime-start-lisp command (generate-new-buffer-name buffername))) + (t + (when-let (conn (find (get-buffer-process buffername) + slime-net-processes + :key #'slime-inferior-process)) + (slime-net-close conn)) + (get-buffer-process buffername)))) + +(defun slime-start-lisp (command buffername) + "Start a new Lisp with command and in the buffer BUFFERNAME. +Return the new process." + (let ((proc (slime-inferior-lisp command buffername))) + (when slime-kill-without-query-p + (process-kill-without-query proc)) + (comint-send-string proc + (format "(load %S :verbose t)\n" + (slime-to-lisp-filename + (if (file-name-absolute-p slime-backend) + slime-backend + (concat slime-path slime-backend))))) + (slime-maybe-start-multiprocessing) + proc)) -(defun slime-start-lisp () - (call-interactively 'inferior-lisp) - (when slime-kill-without-query-p - (process-kill-without-query (inferior-lisp-proc))) - (comint-send-string (inferior-lisp-proc) - (format "(load %S)\n" - (slime-to-lisp-filename - (if (file-name-absolute-p slime-backend) - slime-backend - (concat slime-path slime-backend))))) - (slime-maybe-start-multiprocessing)) +(defun slime-inferior-lisp (command buffername) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (let ((args (split-string command))) + (with-current-buffer (get-buffer-create buffername) + (comint-mode) + (comint-exec (current-buffer) "inferior-lisp" (car args) nil (cdr args)) + (inferior-lisp-mode) + (setq inferior-lisp-buffer (current-buffer)) + (pop-to-buffer (current-buffer)) + (get-buffer-process (current-buffer))))) (defun slime-maybe-start-multiprocessing () (when slime-multiprocessing (comint-send-string (inferior-lisp-proc) "(swank:startup-multiprocessing)\n"))) -(defun slime-inferior-connect (&optional retries) +(defun slime-inferior-connect (process &optional retries) "Start a Swank server in the inferior Lisp and connect." (when (file-regular-p (slime-swank-port-file)) (delete-file (slime-swank-port-file))) - (slime-start-swank-server) - (slime-read-port-and-connect retries)) + (slime-start-swank-server process) + (slime-read-port-and-connect process retries)) -(defun slime-start-swank-server () +(defun slime-start-swank-server (process) "Start a Swank server on the inferior lisp." - (comint-send-string (inferior-lisp-proc) - (format "(swank:start-server %S)\n" - (slime-to-lisp-filename - (slime-swank-port-file))))) + (comint-send-string process (format "(swank:start-server %S)\n" + (slime-to-lisp-filename + (slime-swank-port-file))))) (defun slime-swank-port-file () "Filename where the SWANK server writes its TCP port number." @@ -1335,8 +1354,9 @@ (t "/tmp/"))) (format "slime.%S" (emacs-pid)))) -(defun slime-read-port-and-connect (retries) - (lexical-let ((retries retries) +(defun slime-read-port-and-connect (inferior-process retries) + (lexical-let ((process inferior-process) + (retries retries) (attempt 0)) (labels ;; A small one-state machine to attempt a connection with @@ -1347,14 +1367,16 @@ (message "\ Polling %S.. (Abort with `M-x slime-abort-connection'.)" (slime-swank-port-file))) - (slime-set-state (format "[polling:%S]" (incf attempt))) + (unless (slime-connected-p) + (slime-set-state (format "[polling:%S]" (incf attempt)))) (when slime-connect-retry-timer (cancel-timer slime-connect-retry-timer)) (setq slime-connect-retry-timer nil) ; remove old timer (cond ((file-exists-p (slime-swank-port-file)) (let ((port (slime-read-swank-port))) (delete-file (slime-swank-port-file)) - (slime-connect "127.0.0.1" port))) + (let ((c (slime-connect "127.0.0.1" port))) + (setf (slime-inferior-process c) process)))) ((and retries (zerop retries)) (message "Failed to connect to Swank.")) (t @@ -1483,7 +1505,7 @@ (when (ignore-errors (eq (process-status (inferior-lisp-proc)) 'open)) (message "Lisp connection closed unexpectedly: %s" message)) (slime-net-close process) - (slime-set-state "[not connected]")) + (slime-set-state "[not connected]" process)) ;;; Socket input is handled by `slime-net-filter', which decodes any ;;; complete messages and hands them off to the event dispatcher. @@ -1650,12 +1672,12 @@ "Name of the current state of `slime-default-connection'. Just used for informational display in the mode-line.") -(defun slime-set-state (name) +(defun slime-set-state (name &optional connection) "Set the current connection's informational state name. If this is the default connection then the state will be displayed in the modeline." (when (or (not (slime-connected-p)) - (eq (slime-connection) slime-default-connection)) + (eq (or connection (slime-connection)) slime-default-connection)) (setq slime-state-name name) (force-mode-line-update))) @@ -1728,6 +1750,9 @@ (slime-def-connection-var slime-use-sigint-for-interrupt nil "Non-nil means use SIGINT for interrupting.") +(slime-def-connection-var slime-inferior-process nil + "The inferior process for the connection if any.") + ;;;;; Connection setup (defvar slime-connection-counter 0 @@ -1829,11 +1854,10 @@ (defun slime-process (&optional connection) "Return the Lisp process for CONNECTION (default `slime-connection'). Can return nil if there's no process object for the connection." - (let* ((pid (slime-pid connection)) - (proc (find pid (process-list) :key #'process-id))) - (case (and proc (process-status proc)) - ((run stop) proc) - ((exit nil signal) nil)))) + (let ((proc (slime-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) ;;;; Communication protocol @@ -2321,11 +2345,11 @@ (insert "\n") (set-marker slime-output-end (1- (point))))))) -(defun slime-switch-to-output-buffer (&optional select-connection) +(defun slime-switch-to-output-buffer (&optional connection) "Select the output buffer, preferably in a different window." - (interactive "P") - (let ((slime-dispatching-connection - (if select-connection (slime-choose-connection)))) + (interactive (list (if prefix-arg (slime-choose-connection)))) + (let ((slime-dispatching-connection (or connection + slime-dispatching-connection))) (set-buffer (slime-output-buffer)) (unless (eq (current-buffer) (window-buffer)) (pop-to-buffer (current-buffer) t)) @@ -3058,16 +3082,16 @@ (defslime-repl-shortcut slime-restart-inferior-lisp ("restart-inferior-lisp") (:handler (lambda () (interactive) - (let* ((proc (slime-process)) - (inferior-lisp-program ; for the new process - (if proc - (mapconcat #'identity (process-command proc) " ") - inferior-lisp-program))) - (ignore-errors (kill-process proc)) - (while (comint-check-proc (process-buffer proc)) + (when (slime-connected-p) + (slime-eval-async '(swank:quit-lisp))) + (let ((proc (slime-process))) + (kill-process proc) + (while (memq (process-status proc) '(run stop)) (sit-for 0 20)) - (slime-start-lisp) - (slime-inferior-connect)))) + (let* ((args (mapconcat #'identity (process-command proc) " ")) + (buffer (buffer-name (process-buffer proc))) + (new-proc (slime-start-lisp args buffer))) + (slime-inferior-connect new-proc))))) (:one-liner "Restart *inferior-lisp* and reconnect SLIME.")) @@ -6408,7 +6432,7 @@ (let ((id (get-text-property (point) 'thread-id)) (file (slime-swank-port-file))) (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) - (slime-read-port-and-connect nil)) + (slime-read-port-and-connect nil nil)) (defun slime-thread-debug () (interactive) @@ -6437,8 +6461,8 @@ (defun slime-goto-connection () (interactive) - (let ((slime-dispatching-connection (slime-connection-at-point))) - (slime-switch-to-output-buffer))) + (let ((p (slime-connection-at-point))) + (slime-switch-to-output-buffer p))) (defun slime-connection-list-make-default () (interactive) From heller at common-lisp.net Sun Oct 3 12:27:54 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 03 Oct 2004 14:27:54 +0200 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20320 Modified Files: swank-clisp.lisp Log Message: (getpid)[win32]: Use win32:|GetCurrentProcessId|. From Reini Urban. Date: Sun Oct 3 14:27:54 2004 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.38 slime/swank-clisp.lisp:1.39 --- slime/swank-clisp.lisp:1.38 Fri Sep 17 14:49:26 2004 +++ slime/swank-clisp.lisp Sun Oct 3 14:27:53 2004 @@ -122,7 +122,13 @@ (funcall fn)) #+unix (defmethod getpid () (system::program-id)) -#+win32 (defmethod getpid () (or (system::getenv "PID") -1)) +#+win32 +(defmethod getpid () + (cond ((find-package :win32) + (funcall (find-symbol "GetCurrentProcessId" :win32))) + (t + (system::getenv "PID")))) + ;; the above is likely broken; we need windows NT users! (defimplementation lisp-implementation-type-name () @@ -308,8 +314,11 @@ (sys::redo-eval-frame (nth-frame index))) (defimplementation frame-source-location-for-emacs (index) - (list :error (format nil "Cannot find source for frame: ~A" - (nth-frame index)))) + (let ((f (nth-frame index))) + (list :error (format nil "Cannot find source for frame: ~A ~A ~A" + f + (sys::eval-frame-p f) + (sys::the-frame))))) ;;; Profiling @@ -548,7 +557,8 @@ (declare (ignore inspector)))) (defimplementation quit-lisp () - (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)) + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) ;;; Local Variables: ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1) From heller at common-lisp.net Sun Oct 3 12:33:33 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 03 Oct 2004 14:33:33 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21258 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Oct 3 14:33:33 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.543 slime/ChangeLog:1.544 --- slime/ChangeLog:1.543 Fri Oct 1 15:39:10 2004 +++ slime/ChangeLog Sun Oct 3 14:33:33 2004 @@ -1,3 +1,35 @@ +2004-10-03 Reini Urban + + * swank-clisp.lisp (getpid)[win32]: Use + win32:|GetCurrentProcessId|. + +2004-10-03 Helmut Eller + + * slime.el: Reduce dependency on inf-lisp internals. Make it + possible to start the inferior lisp in a buffer different from + "*inferior-lisp*". + (slime): Parse the command argument explicitly and don't rely on + `inferior-lisp'. Don't close all connections, but only the one + for the inferior lisp buffer we are using. + (slime-maybe-start-lisp): Take the command and buffer as argument. + Decide here whether we should start start a new processwe or just + disconnect and reconnect . + (slime-start-lisp): Load verbosely. + (slime-inferior-lisp): New function. Replaces call to + `inferior-lisp'. + (slime-inferior-connect, slime-start-swank-server): Take the + inferior process as argument + (slime-read-port-and-connect): Set the slime-inferior-process + variable in the new connection. + (slime-inferior-process): New connection local variable. + (slime-process): Use it. + (slime-restart-inferior-lisp): Don't use inferior lisp stuff. + (slime-switch-to-output-buffer): Process interactive arguments + properly. + + * swank-loader.lisp (compile-files-if-needed-serially): Load + verbosely. + 2004-10-01 Helmut Eller * swank-allegro.lisp (find-fspec-location): excl:source-file can @@ -5,7 +37,7 @@ * swank-cmucl.lisp (code-component-entry-points): Only include entry points with "valid" functions names. This excludes internal - lambdas, which have usually a string as name, like "defun foo". + lambdas which have usually a string as name, like "defun foo". * swank.lisp (parse-symbol): Don't use the reader to avoid interning unknown symbols. The downside is that we no longer @@ -14,7 +46,6 @@ * slime.el (slime-set-connection-info): Hide the *inferior-lisp* buffer after we know Lisp's pid. Print the words of encouragement here, when all the other asynchronous initialization is completed. - (slime-find-buffer-package): We need to preserve the case for things like (:in-package "foo"), so return "\"foo\"". From heller at common-lisp.net Sun Oct 3 12:56:10 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 03 Oct 2004 14:56:10 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22618 Modified Files: slime.el Log Message: (slime): Arguments should be optional. Date: Sun Oct 3 14:56:10 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.407 slime/slime.el:1.408 --- slime/slime.el:1.407 Sun Oct 3 14:25:58 2004 +++ slime/slime.el Sun Oct 3 14:56:10 2004 @@ -1157,16 +1157,17 @@ ;;;;; Entry points -(defun slime (command buffer) +(defun slime (&optional command buffer) "Start an inferior^_superior Lisp and connect to its Swank server." (interactive (list (if current-prefix-arg - (read-string "Run lisp: " inferior-lisp-program) - inferior-lisp-program) + (read-string "Run lisp: " inferior-lisp-program)) "*inferior-lisp*")) - (when (or (not (slime-bytecode-stale-p)) - (slime-urge-bytecode-recompile)) - (let ((proc (slime-maybe-start-lisp command buffer))) - (slime-inferior-connect proc nil)))) + (let ((command (or command inferior-lisp-program)) + (buffer (or buffer "*inferior-lisp*"))) + (when (or (not (slime-bytecode-stale-p)) + (slime-urge-bytecode-recompile)) + (let ((proc (slime-maybe-start-lisp command buffer))) + (slime-inferior-connect proc nil))))) (defun slime-connect (host port &optional kill-old-p) "Connect to a running Swank server." From lgorrie at common-lisp.net Tue Oct 5 21:37:39 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 05 Oct 2004 23:37:39 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6826 Modified Files: swank.lisp Log Message: (arglist-for-echo-area): Handle errors and return a message. (parse-symbol): Recognise an empty package name as the KEYWORD package. Date: Tue Oct 5 23:37:36 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.245 slime/swank.lisp:1.246 --- slime/swank.lisp:1.245 Fri Oct 1 14:02:29 2004 +++ slime/swank.lisp Tue Oct 5 23:37:36 2004 @@ -992,7 +992,10 @@ "Find the symbol named STRING. Return the symbol and a flag indicateing if the symbols was found." (multiple-value-bind (sname pname) (tokenize-symbol string) - (find-symbol (casify sname) (if pname (casify pname) package)))) + (find-symbol (casify sname) + (cond ((string= pname "") "KEYWORD") + (pname (casify pname)) + (t package))))) (defun parse-symbol-or-lose (string &optional (package *package*)) (multiple-value-bind (symbol status) (parse-symbol string package) @@ -1045,9 +1048,12 @@ (defslimefun arglist-for-echo-area (names) "Return the arglist for the first function, macro, or special-op in NAMES." - (with-buffer-syntax () - (let ((name (find-if #'valid-operator-name-p names))) - (if name (format-arglist-for-echo-area (parse-symbol name) name))))) + (handler-case + (with-buffer-syntax () + (let ((name (find-if #'valid-operator-name-p names))) + (if name (format-arglist-for-echo-area (parse-symbol name) name)))) + (error (cond) + (format nil "ARGLIST: ~A" cond)))) (defun format-arglist-for-echo-area (symbol name) "Return SYMBOL's arglist as string for display in the echo area. @@ -2540,9 +2546,8 @@ (defmethod inspect-for-emacs ((object cons) (inspector t)) (declare (ignore inspector)) - (if (or (consp (cdr object)) - (null (cdr object))) - (inspect-for-emacs-nontrivial-list object) + (if (listp object) + (inspect-for-emacs-list object) (inspect-for-emacs-simple-cons object))) (defun inspect-for-emacs-simple-cons (cons) @@ -2551,7 +2556,7 @@ (:newline) "Cdr: " (:value ,(cdr cons))))) -(defun inspect-for-emacs-nontrivial-list (list) +(defun inspect-for-emacs-list (list) (let ((circularp nil) (length 0) (seen (make-hash-table :test 'eq)) From lgorrie at common-lisp.net Tue Oct 5 21:39:59 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 05 Oct 2004 23:39:59 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6855 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Oct 5 23:39:59 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.544 slime/ChangeLog:1.545 --- slime/ChangeLog:1.544 Sun Oct 3 14:33:33 2004 +++ slime/ChangeLog Tue Oct 5 23:39:58 2004 @@ -1,3 +1,10 @@ +2004-10-05 Luke Gorrie + + * swank.lisp (arglist-for-echo-area): Handle errors and return a + message. + (parse-symbol): Recognise an empty package name as the KEYWORD + package. + 2004-10-03 Reini Urban * swank-clisp.lisp (getpid)[win32]: Use From lgorrie at common-lisp.net Tue Oct 5 22:15:14 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 06 Oct 2004 00:15:14 +0200 Subject: [slime-cvs] CVS update: slime/doc/slime.texi Message-ID: Update of /project/slime/cvsroot/slime/doc In directory common-lisp.net:/tmp/cvs-serv9302 Modified Files: slime.texi Log Message: (Credits): Updated the credits list to include more Lisp implementors who're also SLIME hackers. Date: Wed Oct 6 00:15:12 2004 Author: lgorrie Index: slime/doc/slime.texi diff -u slime/doc/slime.texi:1.31 slime/doc/slime.texi:1.32 --- slime/doc/slime.texi:1.31 Fri Sep 24 01:17:43 2004 +++ slime/doc/slime.texi Wed Oct 6 00:15:07 2004 @@ -46,7 +46,7 @@ @end macro @set EDITION 1.0 - at set UPDATED @code{$Date: 2004/09/23 23:17:43 $} + at set UPDATED @code{$Date: 2004/10/05 22:15:07 $} @titlepage @title SLIME User Manual @@ -1357,14 +1357,17 @@ We're indebted to the good people of @code{common-lisp.net} for their hosting and help, and for rescuing us from ``Sourceforge hell.'' -Implementors of the Lisps that we support have been a great -help. Thanks to the @acronym{CMUCL} maintainers on the - at code{cmucl-imp} list, Dan Barlow at footnote{Dan is one of ``us'', so -naturally these thanks apply to the @acronym{SBCL}-hacker side of his -personality.} and Christophe Rhodes of @acronym{SBCL}, Gary Byers of -OpenMCL, Martin Simmons of LispWorks (generously sponsored by Alain -Picard of Memetrics), Peter Graves of @acronym{ABCL}, and to Craig -Norvell and Kevin Layer of Franz. +Implementors of the Lisps that we support have been a great help. We'd +like to thank the @acronym{CMUCL} maintainers for their helpful +answers, Craig Norvell and Kevin Layer at Franz providing Allegro CL +licenses for @SLIME{} development, and Peter Graves for his help to +get @SLIME{} running with @acronym{ABCL}. + +Most of all we're happy to be working with the Lisp implementors +who've joined in the @SLIME{} development: Dan Barlow and Christophe +Rhodes of @acronym{SBCL}, Gary Byers of OpenMCL, and Martin Simmons of +LispWorks. Thanks also to Alain Picard and Memetrics for funding +Martin's initial work on the LispWorks backend! @bye From lgorrie at common-lisp.net Tue Oct 5 22:18:14 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 06 Oct 2004 00:18:14 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10130 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Oct 6 00:18:14 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.545 slime/ChangeLog:1.546 --- slime/ChangeLog:1.545 Tue Oct 5 23:39:58 2004 +++ slime/ChangeLog Wed Oct 6 00:18:13 2004 @@ -1,3 +1,8 @@ +2004-10-06 Luke Gorrie + + * doc/slime.texi (Credits): Updated the credits list to include + more Lisp implementors who're also SLIME hackers. + 2004-10-05 Luke Gorrie * swank.lisp (arglist-for-echo-area): Handle errors and return a From lgorrie at common-lisp.net Wed Oct 6 08:59:03 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 06 Oct 2004 10:59:03 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16841 Modified Files: swank.lisp Log Message: (update-indentation/delta-for-emacs): Configure Emacs indentation settings not just for the symbol name but for all package-qualified forms of it as well. Date: Wed Oct 6 10:59:02 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.246 slime/swank.lisp:1.247 --- slime/swank.lisp:1.246 Tue Oct 5 23:37:36 2004 +++ slime/swank.lisp Wed Oct 6 10:59:02 2004 @@ -3248,9 +3248,8 @@ (when indent (unless (equal (gethash symbol cache) indent) (setf (gethash symbol cache) indent) - (push (cons (string-downcase (symbol-name symbol)) - indent) - alist)))))) + (dolist (readname (all-qualified-readnames symbol)) + (push (cons readname indent) alist))))))) (if force (do-all-symbols (symbol) (consider symbol)) @@ -3258,6 +3257,19 @@ (when (eq (symbol-package symbol) *buffer-package*) (consider symbol))))) alist)) + +(defun all-qualified-readnames (symbol) + "Return the list of SYMBOL's readnames with each package qualifier. +The resulting strings are always downcase (for Emacs indentation)." + (cons (symbol-name symbol) + (loop for p in (package-names (symbol-package symbol)) + collect (format nil "~A:~A" + (string-downcase p) + (string-downcase (symbol-name symbol)))))) + +(defun package-names (package) + "Return the name and all nicknames of PACKAGE in a list." + (cons (package-name package) (package-nicknames package))) (defun cl-symbol-p (symbol) "Is SYMBOL a symbol in the COMMON-LISP package?" From lgorrie at common-lisp.net Wed Oct 6 09:08:36 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 06 Oct 2004 11:08:36 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17996 Modified Files: ChangeLog Log Message: Date: Wed Oct 6 11:08:32 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.546 slime/ChangeLog:1.547 --- slime/ChangeLog:1.546 Wed Oct 6 00:18:13 2004 +++ slime/ChangeLog Wed Oct 6 11:08:32 2004 @@ -1,5 +1,9 @@ 2004-10-06 Luke Gorrie + * swank.lisp (update-indentation/delta-for-emacs): Configure Emacs + indentation settings not just for the symbol name but for all + package-qualified forms of it as well. + * doc/slime.texi (Credits): Updated the credits list to include more Lisp implementors who're also SLIME hackers. From mbaringer at common-lisp.net Wed Oct 6 12:39:36 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Wed, 06 Oct 2004 14:39:36 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31305 Modified Files: swank.lisp Log Message: minor inspector cleanups Date: Wed Oct 6 14:39:36 2004 Author: mbaringer Index: slime/swank.lisp diff -u slime/swank.lisp:1.247 slime/swank.lisp:1.248 --- slime/swank.lisp:1.247 Wed Oct 6 10:59:02 2004 +++ slime/swank.lisp Wed Oct 6 14:39:35 2004 @@ -2658,7 +2658,7 @@ (class (when (find-class symbol nil) `("It names the class " (:value ,(find-class symbol) ,(inspector-princ (class-name (find-class symbol)))) " " (:action ,(format nil "[remove name ~S (does not affect class object)]" symbol) - (lambda () (setf (find-class symbol) nil))))))) + ,(lambda () (setf (find-class symbol) nil))))))) (values "A symbol." `("Its name is: " (:value ,(symbol-name symbol)) (:newline) @@ -2715,10 +2715,7 @@ "Its argument list is: " ,(inspector-princ (arglist f)) (:newline) ,@(when (documentation f t) - `("Documentation:" (:newline) ,(documentation f t) (:newline))) - ,@(when (and (function-name f) - - ))))) + `("Documentation:" (:newline) ,(documentation f t) (:newline)))))) (defun method-specializers-for-inspect (method) "Return a \"pretty\" list of the method's specializers. Normal @@ -2816,7 +2813,7 @@ (defmethod inspect-for-emacs ((class standard-class) (inspector t)) (declare (ignore inspector)) - (values "A class." + (values "A stadard class." `("Name: " (:value ,(class-name class)) (:newline) "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) @@ -2962,7 +2959,7 @@ (declare (ignore inspector)) (values "A number." (append - `(,(format nil "Value: ~D = #x~X = #o~O = ~E" i i i i) (:newline)) + `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8B = ~E" i i i i i) (:newline)) (if (< -1 i char-code-limit) (label-value-line "Corresponding character" (code-char i))) (label-value-line "Length" (integer-length i)) From pseibel at common-lisp.net Thu Oct 7 19:33:01 2004 From: pseibel at common-lisp.net (Peter Seibel) Date: Thu, 07 Oct 2004 21:33:01 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18946 Modified Files: swank.lisp ChangeLog Log Message: Bind *debugger-hook* instead of setfing it when spawning threads. Date: Thu Oct 7 21:33:00 2004 Author: pseibel Index: slime/swank.lisp diff -u slime/swank.lisp:1.248 slime/swank.lisp:1.249 --- slime/swank.lisp:1.248 Wed Oct 6 14:39:35 2004 +++ slime/swank.lisp Thu Oct 7 21:33:00 2004 @@ -507,14 +507,14 @@ (defun spawn-threads-for-connection (connection) (let* ((socket-io (connection.socket-io connection)) (control-thread (spawn (lambda () - (setq *debugger-hook* nil) - (dispatch-loop socket-io connection)) + (let ((*debugger-hook* nil)) + (dispatch-loop socket-io connection))) :name "control-thread"))) (setf (connection.control-thread connection) control-thread) (let ((reader-thread (spawn (lambda () - (setq *debugger-hook* nil) - (read-loop control-thread socket-io - connection)) + (let ((*debugger-hook* nil)) + (read-loop control-thread socket-io + connection))) :name "reader-thread")) (repl-thread (spawn (lambda () (repl-loop connection)) :name "repl-thread"))) Index: slime/ChangeLog diff -u slime/ChangeLog:1.547 slime/ChangeLog:1.548 --- slime/ChangeLog:1.547 Wed Oct 6 11:08:32 2004 +++ slime/ChangeLog Thu Oct 7 21:33:00 2004 @@ -1,3 +1,8 @@ +2004-10-07 Peter Seibel + + * swank.lisp (spawn-threads-for-connection): Bind *debugger-hook* + instead of SETF'ing it. + 2004-10-06 Luke Gorrie * swank.lisp (update-indentation/delta-for-emacs): Configure Emacs From heller at common-lisp.net Sun Oct 17 17:48:02 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 19:48:02 +0200 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5853 Modified Files: swank-sbcl.lisp Log Message: (find-defintions): Include sundry compiler stuff. Patch from Thomas Burdick. Date: Sun Oct 17 19:48:00 2004 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.104 slime/swank-sbcl.lisp:1.105 --- slime/swank-sbcl.lisp:1.104 Fri Sep 17 14:51:33 2004 +++ slime/swank-sbcl.lisp Sun Oct 17 19:48:00 2004 @@ -409,20 +409,52 @@ (defun function-definitions (name) (flet ((loc (fn name) (safe-function-source-location fn name))) - (cond ((and (symbolp name) (macro-function name)) - (list (list `(defmacro ,name) - (loc (macro-function name) name)))) - ((fboundp name) - (let ((fn (fdefinition name))) - (typecase fn - (generic-function - (cons (list `(defgeneric ,name) (loc fn name)) - (method-definitions fn))) - (t - (list (list `(function ,name) (loc fn name)))))))))) + (append + (cond ((and (symbolp name) (macro-function name)) + (list (list `(defmacro ,name) + (loc (macro-function name) name)))) + ((fboundp name) + (let ((fn (fdefinition name))) + (typecase fn + (generic-function + (cons (list `(defgeneric ,name) (loc fn name)) + (method-definitions fn))) + (t + (list (list `(function ,name) (loc fn name)))))))) + (when (compiler-macro-function name) + (list (list `(define-compiler-macro ,name) + (loc (compiler-macro-function name) name))))))) + +(defun transform-definitions (fun-info name) + (loop for xform in (sb-c::fun-info-transforms fun-info) + for loc = (safe-function-source-location + (sb-c::transform-function xform) name) + for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform)) + for note = (sb-c::transform-note xform) + for spec = (if (consp typespec) + `(sb-c:deftransform ,(second typespec) ,note) + `(sb-c:deftransform ,note)) + collect `(,spec ,loc))) + +(defun optimizer-definitions (fun-info fun-name) + (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type) + (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate) + (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate) + (sb-c::fun-info-optimizer . sb-c:optimizer)))) + (loop for (reader . name) in otypes + for fn = (funcall reader fun-info) + when fn collect `((sb-c:defoptimizer ,name) + ,(safe-function-source-location fn fun-name))))) + +(defun compiler-definitions (name) + (let ((fun-info (sb-int:info :function :info name))) + (when fun-info + (append (transform-definitions fun-info name) + (optimizer-definitions fun-info name))))) (defimplementation find-definitions (name) - (function-definitions name)) + (append (function-definitions name) + (compiler-definitions name))) (defimplementation describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. From heller at common-lisp.net Sun Oct 17 17:59:47 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 19:59:47 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5938 Modified Files: slime.el Log Message: (slime-find-buffer-package-function): New variable to allow customization for unusal syntax. (slime-maybe-rearrange-inferior-lisp): Removed unused function. (slime-set-inferior-process): Non-macro version to make byte-compiler happy. Reported by Raymond Wiker. (slime-maybe-start-lisp): Use it. (slime-sync-package-and-default-directory): Synch the default-directory in the REPL buffer too. (slime-goto-connection): Close the connection list window. Suggested by Andras Simon. (slime-repl-clear-buffer): Place point after the prompt. (selector-method ?i): Use slime-process to switch to the right buffer. (slime-background-message): Do nothing if the minibuffer is active. (slime-indent-and-complete-symbol): Don't indent if we at the same line as the prompt. Date: Sun Oct 17 19:59:46 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.408 slime/slime.el:1.409 --- slime/slime.el:1.408 Sun Oct 3 14:56:10 2004 +++ slime/slime.el Sun Oct 17 19:59:46 2004 @@ -965,7 +965,8 @@ (if (slime-typeout-active-p) (slime-typeout-message (apply #'format format-string format-args)) (let* ((msg (apply #'format format-string format-args))) - (message "%s" (slime-oneliner msg))))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (message "%s" (slime-oneliner msg)))))) (defun slime-oneliner (string) "Return STRING truncated to fit in a single echo-area line." @@ -1022,7 +1023,8 @@ symbol." (interactive) (let ((pos (point))) - (lisp-indent-line) + (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) + (lisp-indent-line)) (when (and (= pos (point)) (save-excursion (re-search-backward "[^ \n\t\r]+\\=" nil t))) @@ -1282,13 +1284,6 @@ ;;; Starting the inferior Lisp and loading Swank: -(defun slime-maybe-rearrange-inferior-lisp () - "Offer to rename *inferior-lisp* so that another can be started." - (when (y-or-n-p "Create an additional *inferior-lisp*? ") - (with-current-buffer (process-buffer (slime-process)) - (rename-buffer (generate-new-buffer-name (buffer-name))) - t))) - (defun slime-maybe-start-lisp (command buffername) "Start an inferior lisp. Instruct it to load Swank." (cond ((not (comint-check-proc buffername)) @@ -1377,7 +1372,7 @@ (let ((port (slime-read-swank-port))) (delete-file (slime-swank-port-file)) (let ((c (slime-connect "127.0.0.1" port))) - (setf (slime-inferior-process c) process)))) + (slime-set-inferior-process c process)))) ((and retries (zerop retries)) (message "Failed to connect to Swank.")) (t @@ -1860,6 +1855,10 @@ (memq (process-status proc) '(run stop))) proc))) +;; Non-macro version to keep the file byte-compilable. +(defun slime-set-inferior-process (connection process) + (setf (slime-inferior-process connection) process)) + ;;;; Communication protocol @@ -1964,17 +1963,24 @@ (widen) (slime-find-buffer-package)))) +(defvar slime-find-buffer-package-function nil + "Function to use instead of `slime-find-buffer-package'. +The result should be a string. The string will be READ at the Lisp +side.") + (defun slime-find-buffer-package () "Figure out which Lisp package the current buffer is associated with." - (save-excursion - (when (let ((case-fold-search t) - (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>")) - (or (re-search-backward regexp nil t) - (re-search-forward regexp nil t))) - (goto-char (match-end 0)) - (skip-chars-forward " \n\t\f\r#") - (let ((pkg (ignore-errors (read (current-buffer))))) - (if pkg (format "%S" pkg)))))) + (if slime-find-buffer-package-function + (funcall slime-find-buffer-package-function) + (save-excursion + (when (let ((case-fold-search t) + (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>")) + (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t))) + (goto-char (match-end 0)) + (skip-chars-forward " \n\t\f\r#") + (let ((pkg (ignore-errors (read (current-buffer))))) + (if pkg (format "%S" pkg))))))) ;;; Synchronous requests is implemented in terms of asynchronous ;;; ones. We make an asynchronous request with a continuation function @@ -2482,7 +2488,7 @@ ;; xemacs stuff start-open t end-open t) (insert prompt)) - (setq defun-prompt-regexp prompt) + (setq defun-prompt-regexp (concat "^" prompt)) (set-marker slime-output-end start) (set-marker slime-repl-prompt-start-mark prompt-start) (slime-mark-input-start) @@ -2726,7 +2732,8 @@ (interactive) (set-marker slime-repl-last-input-start-mark nil) (let ((inhibit-read-only t)) - (delete-region (point-min) (slime-repl-input-line-beginning-position)))) + (delete-region (point-min) (slime-repl-input-line-beginning-position)) + (goto-char slime-repl-input-start-mark))) (defun slime-repl-clear-output () "See slime-repl-clear-buffer." @@ -4986,7 +4993,8 @@ "Evalute region." (interactive "r") (slime-eval-with-transcript - `(swank:interactive-eval-region ,(buffer-substring-no-properties start end)))) + `(swank:interactive-eval-region + ,(buffer-substring-no-properties start end)))) (defun slime-eval-buffer () "Evalute the current buffer. @@ -5558,8 +5566,14 @@ (let ((dir default-directory)) ;; Sync REPL dir (with-current-buffer (slime-output-buffer) - (setq default-directory dir))) - (message "package: %s default-directory: %s" package directory))) + (setq default-directory dir)) + ;; Sync *inferior-lisp* dir + (let* ((proc (slime-process)) + (buffer (and proc (process-buffer proc)))) + (when buffer + (with-current-buffer buffer + (setq default-directory dir))))) + (message "package: %s default-directory: %s" (car package) directory))) ;;;; Debugger (SLDB) @@ -6461,11 +6475,13 @@ (error "No connection at point"))) (defun slime-goto-connection () + "Switch to the REPL buffer for the connection at point." (interactive) - (let ((p (slime-connection-at-point))) - (slime-switch-to-output-buffer p))) + (let ((slime-dispatching-connection (slime-connection-at-point))) + (switch-to-buffer (slime-output-buffer)))) (defun slime-connection-list-make-default () + "Make the connection at point the default connection." (interactive) (slime-select-connection (slime-connection-at-point)) (slime-update-connection-list)) @@ -6681,9 +6697,9 @@ ;;;; classes browser -(defun slime-expand-class-node (node) +(defun slime-expand-class-node (widget) (or (widget-get widget :args) - (let ((name (widget-get node :tag))) + (let ((name (widget-get widget :tag))) (loop for kid in (slime-eval `(swank:mop :subclasses ,name)) collect `(tree-widget :tag ,kid :dynargs slime-expand-class-node @@ -6714,10 +6730,10 @@ ;;;; Xref browser -(defun slime-expand-xrefs (node) +(defun slime-expand-xrefs (widget) (or (widget-get widget :args) - (let ((name (widget-get node :tag)) - (type (widget-get node :xref-type))) + (let ((name (widget-get widget :tag)) + (type (widget-get widget :xref-type))) (let ((specs (loop for (file . specs) in (slime-eval `(swank:xref ,type ,name)) append specs))) @@ -6807,7 +6823,10 @@ (def-slime-selector-method ?i "the *inferior-lisp* buffer." - "*inferior-lisp*") + (cond ((and (slime-connected-p) (slime-process)) + (process-buffer (slime-process))) + (t + "*inferior-lisp*"))) (def-slime-selector-method ?v "the *slime-events* buffer." From heller at common-lisp.net Sun Oct 17 18:10:05 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 20:10:05 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6908 Modified Files: swank.lisp Log Message: (*sldb-pprint-frames*): Renamed to *sldb-print-pretty*. (*sldb-print-level*, *sldb-print-length*, *sldb-print-circle*) (*sldb-print-readbly): Group of new variables to customize printing in the debugger. The default values should be safe. (define-printer-variables, with-printer-settings): New macros to make definig and binding groups printer variables easier. (inspect-for-emacs-list): Rewritten. The old version had a bug with circular lists, didn't include the position of the element, and always showed the full list. The new version only shows the first 40 elements. (inspect-for-emacs): Minor cleanups. (all-qualified-readnames): Removed. It was not needed because common-lisp-indent-function strips of any package prefix and downcases the symbol anyway. Date: Sun Oct 17 20:10:04 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.249 slime/swank.lisp:1.250 --- slime/swank.lisp:1.249 Thu Oct 7 21:33:00 2004 +++ slime/swank.lisp Sun Oct 17 20:10:03 2004 @@ -22,7 +22,6 @@ #:print-indentation-lossage #:swank-debugger-hook ;; These are user-configurable variables: - #:*sldb-pprint-frames* #:*communication-style* #:*log-events* #:*use-dedicated-output-stream* @@ -75,19 +74,16 @@ (defvar *swank-debug-p* t "When true, print extra debugging information.") -(defvar *sldb-pprint-frames* nil - "*pretty-print* is bound to this value when sldb prints a frame.") - ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via ;;; RPC. (defmacro defslimefun (name arglist &body rest) "A DEFUN for functions that Emacs can call by RPC." `(progn - (defun ,name ,arglist , at rest) - ;; see - (eval-when (:compile-toplevel :load-toplevel :execute) - (export ',name :swank)))) + (defun ,name ,arglist , at rest) + ;; see + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name :swank)))) (declaim (ftype (function () nil) missing-arg)) (defun missing-arg () @@ -245,25 +241,23 @@ `(let* ((,tmp ,value) (,operator (car ,tmp)) (,operands (cdr ,tmp))) - (case ,operator - ,@(mapcar (lambda (clause) - (if (eq (car clause) t) - `(t ,@(cdr clause)) - (destructuring-bind ((op &rest rands) &rest body) - clause - `(,op (destructuring-bind ,rands ,operands - . ,body))))) - patterns) - ,@(if (eq (caar (last patterns)) t) - '() - `((t (error "destructure-case failed: ~S" ,tmp)))))))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t , at body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + , at body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "destructure-case failed: ~S" ,tmp)))))))) (defmacro with-temp-package (var &body body) "Execute BODY with VAR bound to a temporary package. The package is deleted before returning." `(let ((,var (make-package (gensym "TEMP-PACKAGE-")))) - (unwind-protect (progn , at body) - (delete-package ,var)))) + (unwind-protect (progn , at body) + (delete-package ,var)))) ;;;; TCP Server @@ -418,8 +412,8 @@ (defmacro with-reader-error-handler ((connection) &body body) `(handler-case (progn , at body) - (slime-protocol-error (e) - (close-connection ,connection e)))) + (slime-protocol-error (e) + (close-connection ,connection e)))) (defun simple-break () (with-simple-restart (continue "Continue from interrupt.") @@ -701,13 +695,13 @@ (let ((real-stream-var (prefixed-var "REAL" stream-var)) (current-stream-var (prefixed-var "CURRENT" stream-var))) `(progn - ;; Save the real stream value for the future. - (defvar ,real-stream-var ,stream-var) - ;; Define a new variable for the effective stream. - ;; This can be reassigned. - (defvar ,current-stream-var ,stream-var) - ;; Assign the real binding as a synonym for the current one. - (setq ,stream-var (make-synonym-stream ',current-stream-var))))) + ;; Save the real stream value for the future. + (defvar ,real-stream-var ,stream-var) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (defvar ,current-stream-var ,stream-var) + ;; Assign the real binding as a synonym for the current one. + (setq ,stream-var (make-synonym-stream ',current-stream-var))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun prefixed-var (prefix variable-symbol) @@ -900,8 +894,7 @@ (defun read-user-input-from-emacs () (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) (force-output) - (send-to-emacs `(:read-string ,(current-thread) - ,*read-input-catch-tag*)) + (send-to-emacs `(:read-string ,(current-thread) ,*read-input-catch-tag*)) (let ((ok nil)) (unwind-protect (prog1 (catch (intern-catch-tag *read-input-catch-tag*) @@ -909,7 +902,7 @@ (setq ok t)) (unless ok (send-to-emacs `(:read-aborted ,(current-thread) - *read-input-catch-tag*))))))) + *read-input-catch-tag*))))))) (defslimefun take-input (tag input) "Return the string INPUT to the continuation TAG." @@ -949,12 +942,12 @@ Emacs buffer." (destructuring-bind () _ `(let ((*package* *buffer-package*)) - ;; Don't shadow *readtable* unnecessarily because that prevents - ;; the user from assigning to it. - (if (eq *readtable* *buffer-readtable*) - #1=(call-with-syntax-hooks (lambda () , at body)) - (let ((*readtable* *buffer-readtable*)) - #1#))))) + ;; Don't shadow *readtable* unnecessarily because that prevents + ;; the user from assigning to it. + (if (eq *readtable* *buffer-readtable*) + #1=(call-with-syntax-hooks (lambda () , at body)) + (let ((*readtable* *buffer-readtable*)) + #1#))))) (defun from-string (string) "Read string in the *BUFFER-PACKAGE*" @@ -1158,8 +1151,8 @@ (setq ok t)) (force-user-output) (send-to-emacs `(:return ,(current-thread) - ,(if ok `(:ok ,result) '(:abort)) - ,id)))))) + ,(if ok `(:ok ,result) '(:abort)) + ,id)))))) (defun format-values-for-echo-area (values) (with-buffer-syntax () @@ -1236,40 +1229,64 @@ (makunbound name) (prin1-to-string (eval form)))))) -(defvar *swank-pprint-circle* *print-circle* - "*PRINT-CIRCLE* is bound to this value when pretty printing slime output.") - -(defvar *swank-pprint-case* *print-case* - "*PRINT-CASE* is bound to this value when pretty printing slime output.") +(defun foo (&key ((:x a)) ((y b))) + (cons a b)) -(defvar *swank-pprint-right-margin* *print-right-margin* - "*PRINT-RIGHT-MARGIN* is bound to this value when pretty printing slime output.") +(foo 'y 10) -(defvar *swank-pprint-escape* *print-escape* - "*PRINT-ESCAPE* is bound to this value when pretty printing slime output.") -(defvar *swank-pprint-level* *print-level* - "*PRINT-LEVEL* is bound to this value when pretty printing slime output.") +(defmacro define-printer-variables (prefix &body vars) + "Define a group of printer variables. -(defvar *swank-pprint-length* *print-length* - "*PRINT-LENGTH* is bound to this value when pretty printing slime output.") +The elements of VARS can have the form: NAME or (NAME INIT). NAME +must be one of the symbols (pretty circle case escape right-margin +level length). PREFIX and NAME are concatenated, like *PREFIX-NAME*, +to form the names of the actual variable. The new variable is +initialized with INIT or, if INIT was not specified, with the value of +the corresponding printer variable. + +At macroexpansion time the names of the created symbols are stored in +the 'printer-variables property of PREFIX." + (let ((valid-names '(level length circle readably pretty + case escape right-margin))) + (labels ((symconc (prefix suffix) + (intern (format nil "*~A-~A*" (string prefix) (string suffix)) + :swank)) + (parse (var) + (destructuring-bind (name init &optional doc) + (if (consp var) var (list var (symconc 'print var))) + (unless (member name valid-names) + (error "Not a printer variable: ~S" var)) + (list name init doc)))) + (let* ((bindings (mapcar #'parse vars))) + (setf (get prefix 'printer-variables) + (loop for (name) in bindings + collect `(,(symconc 'print name) ,(symconc prefix name)))) + `(progn + ,@(loop for (name init doc) in bindings + collect `(defvar ,(symconc prefix name) ,init ,doc))))))) + +(define-printer-variables swank-pprint + circle level length case right-margin escape) + +(defmacro with-printer-settings (group &body body) + "Rebind the pringer variables in GROUP and execute body. +See `define-printer-variables'." + (let ((bindings (get group 'printer-variables))) + (when (not bindings) (warn "No printer variables for: ~S" group)) + `(let ,bindings , at body))) (defun swank-pprint (list) "Bind some printer variables and pretty print each object in LIST." (with-buffer-syntax () - (let ((*print-pretty* t) - (*print-case* *swank-pprint-case*) - (*print-right-margin* *swank-pprint-right-margin*) - (*print-circle* *swank-pprint-circle*) - (*print-escape* *swank-pprint-escape*) - (*print-level* *swank-pprint-level*) - (*print-length* *swank-pprint-length*)) - (cond ((null list) "; No value") - (t (with-output-to-string (*standard-output*) - (dolist (o list) - (pprint o) - (terpri)))))))) - + (with-printer-settings swank-pprint + (let ((*print-pretty* t)) + (cond ((null list) "; No value") + (t (with-output-to-string (*standard-output*) + (dolist (o list) + (pprint o) + (terpri))))))))) + (defslimefun pprint-eval (string) (with-buffer-syntax () (swank-pprint (multiple-value-list (eval (read-from-string string)))))) @@ -1348,6 +1365,14 @@ (defvar *sldb-restarts* nil "The list of currenlty active restarts.") +;; A set of printer variables used in the debugger. +(define-printer-variables sldb + (pretty nil) + (level 4) + (length 10) + (circle t) + (readably nil)) + (defun debug-in-emacs (condition) (let ((*swank-debugger-condition* condition) (*sldb-restarts* (compute-restarts condition)) @@ -1355,11 +1380,11 @@ (symbol-value '*buffer-package*)) *package*)) (*sldb-level* (1+ *sldb-level*)) - (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)) - (*print-readably* nil)) + (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))) (force-user-output) - (call-with-debugging-environment - (lambda () (sldb-loop *sldb-level*))))) + (with-printer-settings sldb + (call-with-debugging-environment + (lambda () (sldb-loop *sldb-level*)))))) (defun sldb-loop (level) (unwind-protect @@ -1381,7 +1406,7 @@ conditions are simply reported." (let ((real-condition (original-condition condition))) (send-to-emacs `(:debug-condition ,(current-thread) - ,(princ-to-string real-condition)))) + ,(princ-to-string real-condition)))) (throw 'sldb-loop-catcher nil)) (defun safe-condition-message (condition) @@ -1413,10 +1438,8 @@ (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) - (print-frame frame stream))))) + (print-frame frame stream)))) (subseq string (length label)))) ;;;;; SLDB entry points @@ -1501,10 +1524,7 @@ (defslimefun frame-locals-for-emacs (index) "Return a property list ((&key NAME ID VALUE) ...) describing the local variables in the frame INDEX." - (let* ((*print-readably* nil) - (*print-pretty* *sldb-pprint-frames*) - (*print-circle* t) - (*package* (or (frame-package index) *package*))) + (let* ((*package* (or (frame-package index) *package*))) (mapcar (lambda (frame-locals) (destructuring-bind (&key name id value) frame-locals (list :name (prin1-to-string name) :id id @@ -2546,105 +2566,102 @@ (defmethod inspect-for-emacs ((object cons) (inspector t)) (declare (ignore inspector)) - (if (listp object) + (if (consp (cdr object)) (inspect-for-emacs-list object) (inspect-for-emacs-simple-cons object))) (defun inspect-for-emacs-simple-cons (cons) (values "A cons cell." - `("Car: " (:value ,(car cons)) - (:newline) - "Cdr: " (:value ,(cdr cons))))) + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons))))) (defun inspect-for-emacs-list (list) - (let ((circularp nil) - (length 0) - (seen (make-hash-table :test 'eq)) - (contents '())) - (loop - for cons on list - when (gethash cons seen) - do (setf circularp t) and - do (return) - do (push '(:newline) contents) - do (push `(:value ,(car cons)) contents) - do (setf (gethash cons seen) t) - do (incf length)) - (if circularp - (values "A circular list." - `("Contents:" - ,@(nreverse contents))) - (values "A proper list." - `("Length: " (:value ,length) - (:newline) - "Contents:" - ,@(nreverse contents)))))) + (let ((maxlen 40)) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list &rest rest) + (values title + (append '("Elements:" (:newline)) + (loop for i from 0 + for e in list + append (label-value-line i e)) + rest)))) + (cond ((not length) ; circular + (frob "A circular list." + (cons (car list) + (ldiff (cdr list) list)))) + ((and (<= length maxlen) (not tail)) + (frob "A proper list." list)) + (tail + (frob "An improper list." + (subseq list 0 length) + (list :value tail "tail"))) + (t + (frob "A proper list." + (subseq list 0 maxlen) + (list :value (nthcdr maxlen list) "rest")))))))) + +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +NIL is returned if the list is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return nil)) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) (defmethod inspect-for-emacs ((ht hash-table) (inspector t)) (declare (ignore inspector)) (values "A hash table." - `("Count: " (:value ,(hash-table-count ht)) - (:newline) - "Size: " (:value ,(hash-table-size ht)) - (:newline) - "Test: " (:value ,(hash-table-test ht)) - (:newline) - "Rehash size: " (:value ,(hash-table-rehash-size ht)) - (:newline) - "Rehash threshold: " (:value ,(hash-table-rehash-threshold ht)) - (:newline) - "Contents:" (:newline) - ,@(loop - for key being the hash-keys of ht + (append + (label-value-line* + ("Count" (hash-table-count ht)) + ("Size" (hash-table-size ht)) + ("Test" (hash-table-test ht)) + ("Rehash size" (hash-table-rehash-size ht)) + ("Rehash threshold" (hash-table-rehash-threshold ht))) + '("Contents: " (:newline)) + (loop for key being the hash-keys of ht for value being the hash-values of ht - collect `(:value ,key) - collect " = " - collect `(:value ,value) - collect " " - collect `(:newline))))) + append `((:value ,key) " = " (:value ,value) (:newline)))))) (defmethod inspect-for-emacs ((array array) (inspector t)) (declare (ignore inspector)) (values "An array." - `("Dimensions: " (:value ,(array-dimensions array)) - (:newline) - "Its element type is: " (:value ,(array-element-type array)) - (:newline) - "Total size: " (:value ,(array-total-size array)) - (:newline) - ,@(if (array-has-fill-pointer-p array) - `("Its fill-pointer is " (:value ,(fill-pointer array))) - `("No fill pointer.")) - (:newline) - ,(if (adjustable-array-p array) - "It is adjustable." - "It is not adjustable.") - (:newline) - "Contents:" (:newline) - ,@(loop - with darray = (make-array (array-total-size array) - :displaced-to array - :displaced-index-offset 0 - :element-type (array-element-type array)) - for index upfrom 0 - for element across darray - collect `(:value ,element) - collect '(:newline))))) + (append + (label-value-line* + ("Dimensions" (array-dimensions array)) + ("Its element type is" (array-element-type array)) + ("Total size" (array-total-size array)) + ("Fill pointer" (fill-pointer array)) + ("Adjustable" (adjustable-array-p array))) + '("Contents:" (:newline)) + (let ((darray (make-array (array-total-size array) + :displaced-to array + :displaced-index-offset 0))) + (loop for e across darray + for i from 0 + collect (label-value-line i e)))))) (defmethod inspect-for-emacs ((char character) (inspector t)) (declare (ignore inspector)) (values "A character." - `("Char code: " (:value ,(char-code char)) - (:newline) - "Lower cased: " (:value ,(char-downcase char)) - (:newline) - "Upper cased: " (:value ,(char-upcase char)) - (:newline) - ,@(when (get-macro-character char) - `("In the current readtable (" (:value ,*readtable*) ") it is a macro character: " - (:value ,(get-macro-character char)) - (:newline)))))) + (append + (label-value-line* + ("Char code" (char-code char)) + ("Lower cased" (char-downcase char)) + ("Upper cased" (char-upcase char))) + (if (get-macro-character char) + `("In the current readtable (" + (:value ,*readtable*) ") it is a macro character: " + (:value ,(get-macro-character char))))))) +;; Shouldn't most of this stuff be done by describe-symbol-for-emacs? -- he (defmethod inspect-for-emacs ((symbol symbol) (inspector t)) (declare (ignore inspector)) (let ((internal-external (multiple-value-bind (symbol status) @@ -2932,24 +2949,22 @@ (defmethod inspect-for-emacs ((pathname logical-pathname) (inspector t)) (declare (ignore inspector)) (values "A logical pathname." - `("Namestring: " (:value ,(namestring pathname)) - (:newline) - "Physical pathname: " (:value ,(translate-logical-pathname pathname)) - (:newline) - "Host: " (:value ,(pathname-host pathname)) - " (" (:value ,(logical-pathname-translations (pathname-host pathname)) "other translations") ")" - (:newline) - "Directory: " (:value ,(pathname-directory pathname)) - (:newline) - "Name: " (:value ,(pathname-name pathname)) - (:newline) - "Type: " (:value ,(pathname-type pathname)) - (:newline) - "Version: " (:value ,(pathname-version pathname)) - ,@(unless (or (wild-pathname-p pathname) - (not (probe-file pathname))) - `((:newline) - "Truename: " (:value ,(truename pathname))))))) + (append + (label-value-line* + ("Namestring" (namestring pathname)) + ("Physical pathname: " (translate-logical-pathname pathname))) + `("Host: " (pathname-host pathname) + " (" (:value ,(logical-pathname-translations + (pathname-host pathname))) + "other translations)" + (:newline)) + (label-value-line* + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname)) + ("Truename" (if (not (wild-pathname-p pathname)) + (probe-file pathname))))))) (defmethod inspect-for-emacs ((n number) (inspector t)) (declare (ignore inspector)) @@ -2959,7 +2974,9 @@ (declare (ignore inspector)) (values "A number." (append - `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8B = ~E" i i i i i) (:newline)) + `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8B = ~E" + i i i i i) + (:newline)) (if (< -1 i char-code-limit) (label-value-line "Corresponding character" (code-char i))) (label-value-line "Length" (integer-length i)) @@ -3245,8 +3262,7 @@ (when indent (unless (equal (gethash symbol cache) indent) (setf (gethash symbol cache) indent) - (dolist (readname (all-qualified-readnames symbol)) - (push (cons readname indent) alist))))))) + (push (cons (string-downcase symbol) indent) alist)))))) (if force (do-all-symbols (symbol) (consider symbol)) @@ -3254,15 +3270,6 @@ (when (eq (symbol-package symbol) *buffer-package*) (consider symbol))))) alist)) - -(defun all-qualified-readnames (symbol) - "Return the list of SYMBOL's readnames with each package qualifier. -The resulting strings are always downcase (for Emacs indentation)." - (cons (symbol-name symbol) - (loop for p in (package-names (symbol-package symbol)) - collect (format nil "~A:~A" - (string-downcase p) - (string-downcase (symbol-name symbol)))))) (defun package-names (package) "Return the name and all nicknames of PACKAGE in a list." From heller at common-lisp.net Sun Oct 17 18:23:53 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 20:23:53 +0200 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7877 Modified Files: swank-cmucl.lisp Log Message: (return-from-frame): Implemented by Jan Rychter. Requires a recent CMUCL. (inspect-for-emacs (code-component)): Disassemble the memory region if there's not enough debug info. Date: Sun Oct 17 20:23:52 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.122 slime/swank-cmucl.lisp:1.123 --- slime/swank-cmucl.lisp:1.122 Fri Oct 1 14:05:08 2004 +++ slime/swank-cmucl.lisp Sun Oct 17 20:23:52 2004 @@ -1548,6 +1548,16 @@ (defimplementation frame-catch-tags (index) (mapcar #'car (di:frame-catches (nth-frame index)))) +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + (defimplementation sldb-step (frame) (cond ((find-restart 'continue) (set-step-breakpoints (nth-frame frame)) @@ -1888,7 +1898,17 @@ append (label-value-line i (kernel:code-header-ref o i))) `("Code:" (:newline) , (with-output-to-string (s) - (disassem:disassemble-code-component o :stream s)))))) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s)))))))) (defmethod inspect-for-emacs ((o kernel:fdefn) (inspector cmucl-inspector)) (declare (ignore inspector)) From heller at common-lisp.net Sun Oct 17 18:27:49 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 20:27:49 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7908 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Oct 17 20:27:49 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.548 slime/ChangeLog:1.549 --- slime/ChangeLog:1.548 Thu Oct 7 21:33:00 2004 +++ slime/ChangeLog Sun Oct 17 20:27:49 2004 @@ -1,3 +1,51 @@ +2004-10-17 Helmut Eller + + * slime.el: (slime-find-buffer-package-function): New variable to + allow customization for unusal syntax. + (slime-maybe-rearrange-inferior-lisp): Removed unused function. + (slime-set-inferior-process): Non-macro version to make + byte-compiler happy. Reported by Raymond Wiker. + (slime-maybe-start-lisp): Use it. + (slime-sync-package-and-default-directory): Synch the + default-directory in the REPL buffer too. + (slime-goto-connection): Close the connection list window. + Suggested by Andras Simon. + (slime-repl-clear-buffer): Place point after the prompt. + (selector-method ?i): Use slime-process to switch to the right + buffer. + (slime-background-message): Do nothing if the minibuffer is + active. + (slime-indent-and-complete-symbol): Don't indent if we at the same + line as the prompt. + + * swank.lisp (*sldb-pprint-frames*): Renamed to + *sldb-print-pretty*. + (*sldb-print-level*, *sldb-print-length*, *sldb-print-circle*) + (*sldb-print-readbly): Group of new variables to customize + printing in the debugger. The default values should be safe. + (define-printer-variables, with-printer-settings): New macros to + make defining and binding groups of printer variables easier. + (inspect-for-emacs-list): Fix bug with circular lists and only + shows the first 40 elements. + (inspect-for-emacs): Various cleanups. + (all-qualified-readnames): Removed. It was not needed because + common-lisp-indent-function strips of any package prefix and + downcases the symbol anyway. + + * swank-cmucl.lisp (inspect-for-emacs (code-component)): + Disassemble the memory region if there's not enough debug info. + +2004-10-17 Jan Rychter + + * swank-cmucl.lisp (return-from-frame): Add it. + +2004-10-11 Thomas Burdick + + * swank-sbcl.lisp (function-definitions): Find compiler macros, too. + (find-defintions, compiler-definitions) + (optimizer-definitions, transform-definitions): Add compiler + transformers and optimizers to the list of definitions. + 2004-10-07 Peter Seibel * swank.lisp (spawn-threads-for-connection): Bind *debugger-hook* From heller at common-lisp.net Sun Oct 17 18:46:37 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 20:46:37 +0200 Subject: [slime-cvs] CVS update: slime/cl-indent.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9710 Added Files: cl-indent.el Log Message: Put it under CVS. Date: Sun Oct 17 20:46:36 2004 Author: heller From heller at common-lisp.net Sun Oct 17 19:17:55 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 21:17:55 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12600 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Oct 17 21:17:54 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.549 slime/ChangeLog:1.550 --- slime/ChangeLog:1.549 Sun Oct 17 20:27:49 2004 +++ slime/ChangeLog Sun Oct 17 21:17:54 2004 @@ -1,5 +1,8 @@ 2004-10-17 Helmut Eller + * cl-indent.el: Our local copy. Should eventually be merged the + file with in the main distribution. + * slime.el: (slime-find-buffer-package-function): New variable to allow customization for unusal syntax. (slime-maybe-rearrange-inferior-lisp): Removed unused function. From lgorrie at common-lisp.net Sun Oct 17 20:05:42 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 17 Oct 2004 22:05:42 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15652 Modified Files: slime.el Log Message: (slime-message): Use slime-typeout-frame if available. Date: Sun Oct 17 22:05:42 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.409 slime/slime.el:1.410 --- slime/slime.el:1.409 Sun Oct 17 19:59:46 2004 +++ slime/slime.el Sun Oct 17 22:05:41 2004 @@ -103,7 +103,7 @@ ;;;;; slime-ui (defgroup slime-ui nil - "Interfaction with the Superior Lisp Environment." + "Interaction with the Superior Lisp Environment." :prefix "slime-" :group 'slime) @@ -911,16 +911,13 @@ ;; Interface (defun slime-message (format &rest args) "Like `message' but with special support for multi-line messages. -Single-line messages use the echo area. - -Multi-line messages will use the echo area only in GNU Emacs 21. In -other Emacsen they use the \"typeout frame\" if it is active, -otherwise a temporary window that is automatically dismissed before -the next command." - (if (or (featurep 'xemacs) - (= emacs-major-version 20)) - (slime-display-message (apply #'format format args) "*SLIME Note*") - (apply 'message format args))) +Single-line messages use the echo area." + (if (slime-typeout-active-p) + (apply #'slime-typeout-message format args) + (if (or (featurep 'xemacs) + (= emacs-major-version 20)) + (slime-display-message (apply #'format format args) "*SLIME Note*") + (apply 'message format args)))) (defun slime-display-message (message buffer-name) "Display MESSAGE in the echo area or in BUFFER-NAME. From lgorrie at common-lisp.net Sun Oct 17 20:09:24 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 17 Oct 2004 22:09:24 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15774 Modified Files: ChangeLog Log Message: Date: Sun Oct 17 22:09:23 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.550 slime/ChangeLog:1.551 --- slime/ChangeLog:1.550 Sun Oct 17 21:17:54 2004 +++ slime/ChangeLog Sun Oct 17 22:09:23 2004 @@ -1,3 +1,7 @@ +2004-10-17 Luke Gorrie + + * slime.el (slime-message): Use slime-typeout-frame if available. + 2004-10-17 Helmut Eller * cl-indent.el: Our local copy. Should eventually be merged the From heller at common-lisp.net Sun Oct 17 21:50:24 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 23:50:24 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23181 Modified Files: swank.lisp Log Message: (printer-variables sldb-print): Ooops. Better use sldb-print as prefix than sldb alone. *sldb-level* was already defined. Date: Sun Oct 17 23:50:23 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.250 slime/swank.lisp:1.251 --- slime/swank.lisp:1.250 Sun Oct 17 20:10:03 2004 +++ slime/swank.lisp Sun Oct 17 23:50:23 2004 @@ -1366,7 +1366,7 @@ "The list of currenlty active restarts.") ;; A set of printer variables used in the debugger. -(define-printer-variables sldb +(define-printer-variables sldb-print (pretty nil) (level 4) (length 10) @@ -1382,7 +1382,7 @@ (*sldb-level* (1+ *sldb-level*)) (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))) (force-user-output) - (with-printer-settings sldb + (with-printer-settings sldb-print (call-with-debugging-environment (lambda () (sldb-loop *sldb-level*)))))) From heller at common-lisp.net Sun Oct 17 21:51:41 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 17 Oct 2004 23:51:41 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23212 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Oct 17 23:51:40 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.551 slime/ChangeLog:1.552 --- slime/ChangeLog:1.551 Sun Oct 17 22:09:23 2004 +++ slime/ChangeLog Sun Oct 17 23:51:40 2004 @@ -38,6 +38,8 @@ (all-qualified-readnames): Removed. It was not needed because common-lisp-indent-function strips of any package prefix and downcases the symbol anyway. + (printer-variables sldb-print): Ooops. Better use sldb-print as prefix + than sldb alone. *sldb-level* was already defined. * swank-cmucl.lisp (inspect-for-emacs (code-component)): Disassemble the memory region if there's not enough debug info. From heller at common-lisp.net Tue Oct 19 05:57:30 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 19 Oct 2004 07:57:30 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20676 Modified Files: swank.lisp Log Message: (define-printer-variables): NIL is not a valid docstring. Reported by Alain Picard. Date: Tue Oct 19 07:57:30 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.251 slime/swank.lisp:1.252 --- slime/swank.lisp:1.251 Sun Oct 17 23:50:23 2004 +++ slime/swank.lisp Tue Oct 19 07:57:29 2004 @@ -1264,7 +1264,8 @@ collect `(,(symconc 'print name) ,(symconc prefix name)))) `(progn ,@(loop for (name init doc) in bindings - collect `(defvar ,(symconc prefix name) ,init ,doc))))))) + collect `(defvar ,(symconc prefix name) ,init + ,@(if doc doc)))))))) (define-printer-variables swank-pprint circle level length case right-margin escape) @@ -3041,8 +3042,8 @@ (format nil "#~D=~A" pos string) string))) -(defun inspector-content-for-emacs (spec) - (loop for part in spec collect +(defun inspector-content-for-emacs (specs) + (loop for part in specs collect (etypecase part (null ; XXX encourages sloppy programming nil) From heller at common-lisp.net Tue Oct 19 06:14:17 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 19 Oct 2004 08:14:17 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21698 Modified Files: swank.lisp Log Message: (define-printer-variables): Allow print-gensym, base and others. (printer-variables sldb-print): Include print-gensym, pprint-dispatch, base, radix, array, lines. Date: Tue Oct 19 08:14:17 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.252 slime/swank.lisp:1.253 --- slime/swank.lisp:1.252 Tue Oct 19 07:57:29 2004 +++ slime/swank.lisp Tue Oct 19 08:14:17 2004 @@ -1215,7 +1215,6 @@ shortest) finally (return shortest))) - (defslimefun interactive-eval-region (string) (with-buffer-syntax () (format-values-for-echo-area (eval-region string)))) @@ -1229,12 +1228,6 @@ (makunbound name) (prin1-to-string (eval form)))))) -(defun foo (&key ((:x a)) ((y b))) - (cons a b)) - -(foo 'y 10) - - (defmacro define-printer-variables (prefix &body vars) "Define a group of printer variables. @@ -1248,7 +1241,8 @@ At macroexpansion time the names of the created symbols are stored in the 'printer-variables property of PREFIX." (let ((valid-names '(level length circle readably pretty - case escape right-margin))) + case escape right-margin miser-width + base radix gensym array lines pprint-dispatch))) (labels ((symconc (prefix suffix) (intern (format nil "*~A-~A*" (string prefix) (string suffix)) :swank)) @@ -1267,6 +1261,7 @@ collect `(defvar ,(symconc prefix name) ,init ,@(if doc doc)))))))) + (define-printer-variables swank-pprint circle level length case right-margin escape) @@ -1372,7 +1367,8 @@ (level 4) (length 10) (circle t) - (readably nil)) + (readably nil) + gensym pprint-dispatch base radix array lines) (defun debug-in-emacs (condition) (let ((*swank-debugger-condition* condition) From heller at common-lisp.net Tue Oct 19 07:04:31 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 19 Oct 2004 09:04:31 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25941 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Oct 19 09:04:30 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.552 slime/ChangeLog:1.553 --- slime/ChangeLog:1.552 Sun Oct 17 23:51:40 2004 +++ slime/ChangeLog Tue Oct 19 09:04:30 2004 @@ -1,3 +1,10 @@ +2004-10-19 Helmut Eller + + * swank.lisp (define-printer-variables): NIL is not a valid + docstring. Reported by Alain Picard. + (printer-variables sldb-print): Include print-gensym, + pprint-dispatch, base, radix, array, and lines. + 2004-10-17 Luke Gorrie * slime.el (slime-message): Use slime-typeout-frame if available. From lgorrie at common-lisp.net Tue Oct 19 18:54:21 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 19 Oct 2004 20:54:21 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7761 Modified Files: slime.el Log Message: (slime-show-source-location): Call `set-mark-command' to push the source position onto the global mark ring. Date: Tue Oct 19 20:54:21 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.410 slime/slime.el:1.411 --- slime/slime.el:1.410 Sun Oct 17 22:05:41 2004 +++ slime/slime.el Tue Oct 19 20:54:19 2004 @@ -6044,6 +6044,7 @@ (let ((w (select-window (or (get-buffer-window (current-buffer) t) (display-buffer (current-buffer) t))))) (goto-char position) + (set-mark-command nil) (unless (pos-visible-in-window-p) (slime-recenter-window w sldb-show-location-recenter-arg)))))) From lgorrie at common-lisp.net Tue Oct 19 18:55:14 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 19 Oct 2004 20:55:14 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7782 Modified Files: ChangeLog Log Message: Date: Tue Oct 19 20:55:14 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.553 slime/ChangeLog:1.554 --- slime/ChangeLog:1.553 Tue Oct 19 09:04:30 2004 +++ slime/ChangeLog Tue Oct 19 20:55:14 2004 @@ -1,3 +1,8 @@ +2004-10-19 Luke Gorrie + + * slime.el (slime-show-source-location): Call `set-mark-command' + to push the source position onto the global mark ring. + 2004-10-19 Helmut Eller * swank.lisp (define-printer-variables): NIL is not a valid From lgorrie at common-lisp.net Tue Oct 19 18:59:39 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 19 Oct 2004 20:59:39 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7835 Modified Files: slime.el Log Message: slime-show-source-location: Use `push-mark' instead of `set-mark-command'. Date: Tue Oct 19 20:59:39 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.411 slime/slime.el:1.412 --- slime/slime.el:1.411 Tue Oct 19 20:54:19 2004 +++ slime/slime.el Tue Oct 19 20:59:39 2004 @@ -6044,7 +6044,7 @@ (let ((w (select-window (or (get-buffer-window (current-buffer) t) (display-buffer (current-buffer) t))))) (goto-char position) - (set-mark-command nil) + (push-mark) (unless (pos-visible-in-window-p) (slime-recenter-window w sldb-show-location-recenter-arg)))))) From lgorrie at common-lisp.net Tue Oct 19 18:59:53 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 19 Oct 2004 20:59:53 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7854 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Oct 19 20:59:52 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.554 slime/ChangeLog:1.555 --- slime/ChangeLog:1.554 Tue Oct 19 20:55:14 2004 +++ slime/ChangeLog Tue Oct 19 20:59:52 2004 @@ -1,7 +1,7 @@ 2004-10-19 Luke Gorrie - * slime.el (slime-show-source-location): Call `set-mark-command' - to push the source position onto the global mark ring. + * slime.el (slime-show-source-location): Call `push-mark' to push + the source position onto the global mark ring. 2004-10-19 Helmut Eller From mbaringer at common-lisp.net Mon Oct 25 16:15:26 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Mon, 25 Oct 2004 18:15:26 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7476 Modified Files: slime.el Log Message: (slime-repl-defparameter): Change default value to "*". Date: Mon Oct 25 18:15:24 2004 Author: mbaringer Index: slime/slime.el diff -u slime/slime.el:1.412 slime/slime.el:1.413 --- slime/slime.el:1.412 Tue Oct 19 20:59:39 2004 +++ slime/slime.el Mon Oct 25 18:15:19 2004 @@ -3042,7 +3042,7 @@ (defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!") (:handler (lambda (name value) (interactive (list (slime-read-symbol-name "Name (symbol): " t) - (slime-read-from-minibuffer "Value: " "nil"))) + (slime-read-from-minibuffer "Value: " "*"))) (insert "(cl:defparameter " name " " value " \"REPL generated global variable.\")") (slime-repl-send-input))) From mbaringer at common-lisp.net Mon Oct 25 16:17:12 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Mon, 25 Oct 2004 18:17:12 +0200 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8119 Modified Files: swank-allegro.lisp Log Message: (inspect-for-emacs): Use excl::external-fn_symdef to get the function documentation. Date: Mon Oct 25 18:17:11 2004 Author: mbaringer Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.60 slime/swank-allegro.lisp:1.61 --- slime/swank-allegro.lisp:1.60 Fri Oct 1 14:16:44 2004 +++ slime/swank-allegro.lisp Mon Oct 25 18:17:11 2004 @@ -418,8 +418,9 @@ (values "A function." `("Name: " (:value ,(function-name f)) (:newline) "Its argument list is: " ,(princ-to-string (arglist f)) (:newline) - "Documentation:" (:newline) - ,(documentation f 'function)))) + ,@ (let ((doc (documentation (excl::external-fn_symdef f) 'function))) + (when doc + `("Documentation:" (:newline) ,doc)))))) (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector)) (values "A structure class." From mbaringer at common-lisp.net Mon Oct 25 16:17:58 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Mon, 25 Oct 2004 18:17:58 +0200 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8186 Modified Files: swank-cmucl.lisp Log Message: (inspect-for-emacs function): Use next method's values and simply add cmucl specific details. Date: Mon Oct 25 18:17:57 2004 Author: mbaringer Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.123 slime/swank-cmucl.lisp:1.124 --- slime/swank-cmucl.lisp:1.123 Sun Oct 17 20:23:52 2004 +++ slime/swank-cmucl.lisp Mon Oct 25 18:17:57 2004 @@ -1857,30 +1857,31 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))))) -(defmethod inspect-for-emacs ((o function) (inspector cmucl-inspector)) +(defmethod inspect-for-emacs :around ((o function) (inspector cmucl-inspector)) (declare (ignore inspector)) - (let ((header (kernel:get-type o))) - (cond ((= header vm:function-header-type) - (values (format nil "~A is a function." o) - (append (label-value-line* - ("self" (kernel:%function-self o)) - ("next" (kernel:%function-next o)) - ("name" (kernel:%function-name o)) - ("arglist" (kernel:%function-arglist o)) - ("type" (kernel:%function-type o)) - ("code" (kernel:function-code-header o))) - (list - (with-output-to-string (s) - (disassem:disassemble-function o :stream s)))))) - ((= header vm:closure-header-type) - (values (format nil "~A is a closure" o) - (append - (label-value-line "function" (kernel:%closure-function o)) - `("Environment:" (:newline)) - (loop for i from 0 below (1- (kernel:get-closure-length o)) - append (label-value-line - i (kernel:%closure-index-ref o i)))))) - (t (call-next-method o))))) + (multiple-value-bind (title contents) + (call-next-method) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (values (format nil "~A is a function." o) + (append contents + (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (values (format nil "~A is a closure" o) + (append + (label-value-line "Function Object" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop + for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line i (kernel:%closure-index-ref o i)))))) + (t (values title contents)))))) (defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector)) (declare (ignore _)) From mbaringer at common-lisp.net Mon Oct 25 16:18:28 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Mon, 25 Oct 2004 18:18:28 +0200 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8207 Modified Files: swank-openmcl.lisp Log Message: (specializer-name): New function. (who-specializes): Use it. (maybe-method-location): Use it. (function-source-location): Use it. Date: Mon Oct 25 18:18:28 2004 Author: mbaringer Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.85 slime/swank-openmcl.lisp:1.86 --- slime/swank-openmcl.lisp:1.85 Fri Sep 17 14:51:07 2004 +++ slime/swank-openmcl.lisp Mon Oct 25 18:18:27 2004 @@ -115,6 +115,12 @@ openmcl-mop:slot-definition-readers openmcl-mop:slot-definition-writers)) +(defun specializer-name (spec) + (etypecase spec + (cons spec) + ((or swank-mop:standard-class built-in-class) (swank-mop:class-name spec)) + (swank-mop:eql-specializer `(eql ,(swank-mop:eql-specializer-object spec))))) + ;;; TCP Server (defimplementation preferred-communication-style () @@ -314,7 +320,9 @@ (let ((location (function-source-location (ccl::method-function m)))) (if (eq (car location) :error) (setq location nil )) - `((method ,(ccl::method-name m) ,(mapcar 'class-name (ccl::method-specializers m)) ,@(ccl::method-qualifiers m)) + `((method ,(ccl::method-name m) + ,(mapcar #'specializer-name (ccl::method-specializers m)) + ,@(ccl::method-qualifiers m)) ,location))) (ccl::%class.direct-methods class)) (mapcan 'who-specializes (ccl::%class-direct-subclasses class))) @@ -519,7 +527,9 @@ (defun maybe-method-location (type) (when (typep type 'ccl::method) - `((method ,(ccl::method-name type) ,(mapcar 'class-name (ccl::method-specializers type)) ,@(ccl::method-qualifiers type)) + `((method ,(ccl::method-name type) + ,(mapcar #'specializer-name (ccl::method-specializers type)) + ,@(ccl::method-qualifiers type)) ,(function-source-location (ccl::method-function type))))) (defimplementation find-definitions (symbol) @@ -538,7 +548,9 @@ `(:location (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) ))) (:method ,(princ-to-string (ccl::method-name (caar info))) - ,(mapcar 'princ-to-string (mapcar 'class-name (ccl::method-specializers (caar info)))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers (caar info)))) ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) nil)) (t (canonicalize-location (cdr (first info)) name))))) From mbaringer at common-lisp.net Mon Oct 25 16:19:33 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Mon, 25 Oct 2004 18:19:33 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8228 Modified Files: swank.lisp Log Message: (inspect-for-emacs array): Properly deal with arrays without fill pointers. (inspect-for-emacs function): Show function-lambda-expression when available. (inspect-for-emacs generic-function): Order generic function's methods and show abbreviated docs for methods. (abbrev-doc): New function. (methods-by-applicability): New function. (*gf-method-getter*): New variable. Date: Mon Oct 25 18:19:32 2004 Author: mbaringer Index: slime/swank.lisp diff -u slime/swank.lisp:1.253 slime/swank.lisp:1.254 --- slime/swank.lisp:1.253 Tue Oct 19 08:14:17 2004 +++ slime/swank.lisp Mon Oct 25 18:19:32 2004 @@ -2635,15 +2635,17 @@ ("Dimensions" (array-dimensions array)) ("Its element type is" (array-element-type array)) ("Total size" (array-total-size array)) - ("Fill pointer" (fill-pointer array)) ("Adjustable" (adjustable-array-p array))) + (when (array-has-fill-pointer-p array) + `(("Fill pointer" (fill-pointer array)))) '("Contents:" (:newline)) (let ((darray (make-array (array-total-size array) + :element-type (array-element-type array) :displaced-to array :displaced-index-offset 0))) (loop for e across darray for i from 0 - collect (label-value-line i e)))))) + append (label-value-line i e)))))) (defmethod inspect-for-emacs ((char character) (inspector t)) (declare (ignore inspector)) @@ -2728,6 +2730,8 @@ `("Name: " (:value ,(function-name f)) (:newline) "Its argument list is: " ,(inspector-princ (arglist f)) (:newline) + ,@(when (function-lambda-expression f) + `("Lambda Expression: " (:value ,(function-lambda-expression f)) (:newline))) ,@(when (documentation f t) `("Documentation:" (:newline) ,(documentation f t) (:newline)))))) @@ -2778,7 +2782,7 @@ (swank-mop:slot-definition-name slot))) direct-slots) slot) - collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def))) + collect `(:value ,slot-def ,(inspector-princ (swank-mop:slot-definition-name slot-def))) collect " = " if (slot-boundp o (swank-mop:slot-definition-name slot-def)) collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def))) @@ -2786,6 +2790,67 @@ collect "#" collect '(:newline))))) +(defvar *gf-method-getter* 'methods-by-applicability + "This function is called to get the methods of a generic function. +The default returns the method sorted by applicability. +See `methods-by-applicability'.") + +;;; Largely inspired by (+ copied from) the McCLIM listener +(defun methods-by-applicability (gf) + "Return methods ordered by qualifiers, then by most specific argument types. + +Qualifier ordering is: :before, :around, primary, and :after. +We use the length of the class precedence list to determine which type is +more specific." + ;;FIXME: How to deal with argument-precedence-order? + (let ((methods (copy-list (swank-mop:generic-function-methods gf)))) + ;; sorter function (most specific is defined as smaller) + (flet ((method< (meth1 meth2) + ;; First ordering rule is by qualifiers, that is :before-methods + ;; come before :around methods, before primary methods, before + ;; :after methods, other qualifiers are treated like none at all + ;; (so like primary methods) + (let ((qualifier-order '(:before :around nil :after))) + (let ((q1 (or (position (first (swank-mop:method-qualifiers meth1)) qualifier-order) 2)) + (q2 (or (position (first (swank-mop:method-qualifiers meth2)) qualifier-order) 2))) + (cond ((< q1 q2) (return-from method< t)) + ((> q1 q2) (return-from method< nil))))) + ;; If qualifiers are equal, go by arguments + (loop for sp1 in (swank-mop:method-specializers meth1) + for sp2 in (swank-mop:method-specializers meth2) + do (cond + ((eq sp1 sp2)) ;; continue comparision + ;; an eql specializer is most specific + ((typep sp1 'swank-mop:eql-specializer) + (return-from method< t)) + ((typep sp2 'swank-mop:eql-specializer) + (return-from method< nil)) + ;; otherwise the longer the CPL the more specific + ;; the specializer is + ;; FIXME: Taking the CPL as indicator has the problem + ;; that unfinalized classes are most specific. Can we pick + ;; a reasonable default or do something with SUBTYPEP ? + (t (let ((l1 (if (swank-mop:class-finalized-p sp1) + (length (swank-mop:class-precedence-list sp1)) + 0)) + (l2 (if (swank-mop:class-finalized-p sp2) + (length (swank-mop:class-precedence-list sp2)) + 0))) + (cond + ((> l1 l2) + (return-from method< t)) + ((< l1 l2) + (return-from method< nil)))))) + finally (return nil)))) + (declare (dynamic-extent #'method<)) + (sort methods #'method<)))) + +(defun abbrev-doc (doc &optional (maxlen 80)) + "Return the first sentence of DOC, but not more than MAXLAN characters." + (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) + maxlen + (length doc)))) + (defmethod inspect-for-emacs ((gf standard-generic-function) (inspector t)) (declare (ignore inspector)) (values "A generic function." @@ -2797,13 +2862,17 @@ "It uses " (:value ,(swank-mop:generic-function-method-combination gf)) " method combination." (:newline) "Methods: " (:newline) ,@(loop - for method in (swank-mop:generic-function-methods gf) + for method in (funcall *gf-method-getter* gf) collect `(:value ,method ,(inspector-princ ;; drop the first element (the name of the generic function) (cdr (method-for-inspect-value method)))) collect " " collect (let ((meth method)) `(:action "[remove method]" ,(lambda () (remove-method gf meth)))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and collect '(:newline))))) (defmethod inspect-for-emacs ((method standard-method) (inspector t)) @@ -2827,41 +2896,56 @@ (defmethod inspect-for-emacs ((class standard-class) (inspector t)) (declare (ignore inspector)) - (values "A stadard class." + (values "A class." `("Name: " (:value ,(class-name class)) (:newline) - "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) + "Super classes: " + ,@(common-seperated-spec (swank-mop:class-direct-superclasses class)) (:newline) - "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ - (swank-mop:slot-definition-name slot))))) - (:newline) - "Effective Slots: " ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec (swank-mop:class-slots class) - (lambda (slot) - `(:value ,slot ,(inspector-princ - (swank-mop:slot-definition-name slot))))) - '("#")) + "Direct Slots: " + ,@(common-seperated-spec + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (swank-mop:slot-definition-name slot))))) + '("#")) (:newline) ,@(when (documentation class t) - `("Documentation:" (:newline) - ,(documentation class t) (:newline))) - "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) - (lambda (sub) - `(:value ,sub ,(inspector-princ (class-name sub))))) - (:newline) - "Precedence List: " ,@(if (swank-mop:class-finalized-p class) - (common-seperated-spec (swank-mop:class-precedence-list class) - (lambda (class) - `(:value ,class ,(inspector-princ (class-name class))))) - '("#")) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(common-seperated-spec (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(inspector-princ (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (common-seperated-spec (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(inspector-princ (class-name class))))) + '("#")) (:newline) ,@(when (swank-mop:specializer-direct-methods class) `("It is used as a direct specializer in the following methods:" (:newline) ,@(loop - for method in (swank-mop:specializer-direct-methods class) + for method in (sort (copy-list (swank-mop:specializer-direct-methods class)) + #'string< :key (lambda (x) + (symbol-name + (let ((name (swank-mop::generic-function-name + (swank-mop::method-generic-function x)))) + (if (symbolp name) name (second name)))))) + collect " " collect `(:value ,method ,(inspector-princ (method-for-inspect-value method))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and collect '(:newline)))) "Prototype: " ,(if (swank-mop:class-finalized-p class) `(:value ,(swank-mop:class-prototype class)) From mbaringer at common-lisp.net Mon Oct 25 16:20:44 2004 From: mbaringer at common-lisp.net (Marco Baringer) Date: Mon, 25 Oct 2004 18:20:44 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8256 Modified Files: ChangeLog Log Message: Date: Mon Oct 25 18:20:43 2004 Author: mbaringer Index: slime/ChangeLog diff -u slime/ChangeLog:1.555 slime/ChangeLog:1.556 --- slime/ChangeLog:1.555 Tue Oct 19 20:59:52 2004 +++ slime/ChangeLog Mon Oct 25 18:20:43 2004 @@ -1,3 +1,31 @@ +2004-10-25 Marco Baringer + + * swank.lisp (inspect-for-emacs array): Properly deal with arrays + without fill pointers. + (inspect-for-emacs function): Show function-lambda-expression + when available. + + * swank-openmcl.lisp (specializer-name): New function. + (who-specializes): Use it. + (maybe-method-location): Use it. + (function-source-location): Use it. + + * swank-cmucl.lisp (inspect-for-emacs function): Use next + method's values and simply add cmucl specific details. + + * slime.el (slime-repl-defparameter): Change default value to "*". + +2004-10-25 Thomas Schilling + + * swank-allegro.lisp (inspect-for-emacs): Use + excl::external-fn_symdef to get the function documentation. + + * swank.lisp (inspect-for-emacs): Order generic function's methods + and show abbreviated docs for methods. + (abbrev-doc): New function. + (methods-by-applicability): New function. + (*gf-method-getter*): New variable. + 2004-10-19 Luke Gorrie * slime.el (slime-show-source-location): Call `push-mark' to push From heller at common-lisp.net Tue Oct 26 00:28:17 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:28:17 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8821 Modified Files: slime.el Log Message: (slime-init-command): New function to send the command to load swank. Havering a separate function for the task should make it easier to start a Lips with a preloaded swank. (slime-maybe-start-lisp): Use it. (slime-maybe-start-multiprocessing): Deleted. (slime-repl-buffer): Include the name of the implementation. (slime-set-default-directory) (slime-sync-package-and-default-directory): Translate filenames. Date: Tue Oct 26 02:28:16 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.413 slime/slime.el:1.414 --- slime/slime.el:1.413 Mon Oct 25 18:15:19 2004 +++ slime/slime.el Tue Oct 26 02:28:16 2004 @@ -1284,9 +1284,10 @@ (defun slime-maybe-start-lisp (command buffername) "Start an inferior lisp. Instruct it to load Swank." (cond ((not (comint-check-proc buffername)) - (slime-start-lisp command buffername)) + (slime-start-lisp command buffername (slime-init-command))) ((y-or-n-p "Create an additional *inferior-lisp*? ") - (slime-start-lisp command (generate-new-buffer-name buffername))) + (slime-start-lisp command (generate-new-buffer-name buffername) + (slime-init-command))) (t (when-let (conn (find (get-buffer-process buffername) slime-net-processes @@ -1294,25 +1295,28 @@ (slime-net-close conn)) (get-buffer-process buffername)))) -(defun slime-start-lisp (command buffername) - "Start a new Lisp with command and in the buffer BUFFERNAME. +(defun slime-init-command () + "Return a string to initialize Lisp." + (let ((swank (slime-to-lisp-filename (if (file-name-absolute-p slime-backend) + slime-backend + (concat slime-path slime-backend)))) + (mp (if slime-multiprocessing "(swank:startup-multiprocessing)\n" ""))) + (format "(load %S :verbose t)\n%s" swank mp))) + +(defun slime-start-lisp (command buffername init-string) + "Start Lisp with COMMAND in BUFFERNAME and send INIT-STRING to it. Return the new process." (let ((proc (slime-inferior-lisp command buffername))) (when slime-kill-without-query-p (process-kill-without-query proc)) - (comint-send-string proc - (format "(load %S :verbose t)\n" - (slime-to-lisp-filename - (if (file-name-absolute-p slime-backend) - slime-backend - (concat slime-path slime-backend))))) - (slime-maybe-start-multiprocessing) - proc)) + (when init-string + (comint-send-string proc init-string) + proc))) (defun slime-inferior-lisp (command buffername) "Does the same as `inferior-lisp' but less ugly. Return the created process." - (let ((args (split-string command))) + (let ((args (split-string command))) ; XXX consider: cmucl -eval '(+ 1 2)' (with-current-buffer (get-buffer-create buffername) (comint-mode) (comint-exec (current-buffer) "inferior-lisp" (car args) nil (cdr args)) @@ -1321,11 +1325,6 @@ (pop-to-buffer (current-buffer)) (get-buffer-process (current-buffer))))) -(defun slime-maybe-start-multiprocessing () - (when slime-multiprocessing - (comint-send-string (inferior-lisp-proc) - "(swank:startup-multiprocessing)\n"))) - (defun slime-inferior-connect (process &optional retries) "Start a Swank server in the inferior Lisp and connect." (when (file-regular-p (slime-swank-port-file)) @@ -2443,7 +2442,7 @@ (defun slime-repl-buffer (&optional create) "Get the REPL buffer for the current connection; optionally create." (funcall (if create #'get-buffer-create #'get-buffer) - (format "*slime-repl[%S]*" (slime-connection-number)))) + (format "*slime-repl %s*" (slime-connection-name)))) (defun slime-repl-mode () "Major mode for interacting with a superior Lisp. @@ -3387,9 +3386,9 @@ (defun slime-maybe-list-compiler-notes (notes) "Show the compiler notes if appropriate." - (unless (or (null notes) - (and (eq last-command 'slime-compile-defun) - (every #'slime-note-has-location-p notes))) + ;; don't pop up a buffer if all notes will are already annotated in + ;; the buffer itself + (unless (every #'slime-note-has-location-p notes) (slime-list-compiler-notes notes))) (defun slime-list-compiler-notes (&optional notes) @@ -5545,9 +5544,10 @@ (defun slime-set-default-directory (directory) "Make DIRECTION become Lisp's current directory." (interactive (list (read-directory-name "Directory: " nil nil t))) - (message "default-directory: %s" - (slime-eval `(swank:set-default-directory - ,(expand-file-name directory)))) + (message "default-directory: %s" + (slime-from-lisp-filename + (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename directory))))) (with-current-buffer (slime-output-buffer) (setq default-directory (expand-file-name directory)) (when (boundp 'header-line-format) @@ -5558,8 +5558,10 @@ (interactive) (let ((package (slime-eval `(swank:set-package ,(slime-find-buffer-package)))) - (directory (slime-eval `(swank:set-default-directory - ,(expand-file-name default-directory))))) + (directory (slime-from-lisp-filename + (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename + default-directory)))))) (let ((dir default-directory)) ;; Sync REPL dir (with-current-buffer (slime-output-buffer) From heller at common-lisp.net Tue Oct 26 00:30:49 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:30:49 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9414 Modified Files: swank.lisp Log Message: (define-printer-variables): Handle doc strings properly. (*sldb-pprint-dispatch*): Initialize it with the default dispatch table. Date: Tue Oct 26 02:30:48 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.254 slime/swank.lisp:1.255 --- slime/swank.lisp:1.254 Mon Oct 25 18:19:32 2004 +++ slime/swank.lisp Tue Oct 26 02:30:47 2004 @@ -813,7 +813,8 @@ "Write a message to *terminal-io* when *log-events* is non-nil. Useful for low level debugging." (when *log-events* - (apply #'format *log-io* format-string args))) + (apply #'format *log-io* format-string args) + (force-output *log-io*))) (defun read-from-emacs () "Read and process a request from Emacs." @@ -1189,7 +1190,8 @@ (return (values values -))))) (when (and package-update-p (not (eq *package* *buffer-package*))) (send-to-emacs - (list :new-package (package-name *package*) (package-string-for-prompt *package*))))))) + (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) (defun package-string-for-prompt (package) "Return the shortest nickname (or canonical name) of PACKAGE." @@ -1259,7 +1261,7 @@ `(progn ,@(loop for (name init doc) in bindings collect `(defvar ,(symconc prefix name) ,init - ,@(if doc doc)))))))) + ,@(if doc (list doc))))))))) (define-printer-variables swank-pprint @@ -1368,7 +1370,8 @@ (length 10) (circle t) (readably nil) - gensym pprint-dispatch base radix array lines) + (pprint-dispatch (copy-pprint-dispatch nil)) + gensym base radix array lines) (defun debug-in-emacs (condition) (let ((*swank-debugger-condition* condition) @@ -2561,7 +2564,7 @@ (t (princ object as-string))))) (printer list)))) -(defmethod inspect-for-emacs ((object cons) (inspector t)) +(defmethod inspect-for-emacs ((object cons) inspector) (declare (ignore inspector)) (if (consp (cdr object)) (inspect-for-emacs-list object) @@ -2612,7 +2615,7 @@ ((and (eq fast slow) (> n 0)) (return nil)) ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) -(defmethod inspect-for-emacs ((ht hash-table) (inspector t)) +(defmethod inspect-for-emacs ((ht hash-table) inspector) (declare (ignore inspector)) (values "A hash table." (append @@ -2627,7 +2630,7 @@ for value being the hash-values of ht append `((:value ,key) " = " (:value ,value) (:newline)))))) -(defmethod inspect-for-emacs ((array array) (inspector t)) +(defmethod inspect-for-emacs ((array array) inspector) (declare (ignore inspector)) (values "An array." (append @@ -2647,7 +2650,7 @@ for i from 0 append (label-value-line i e)))))) -(defmethod inspect-for-emacs ((char character) (inspector t)) +(defmethod inspect-for-emacs ((char character) inspector) (declare (ignore inspector)) (values "A character." (append @@ -2661,7 +2664,7 @@ (:value ,(get-macro-character char))))))) ;; Shouldn't most of this stuff be done by describe-symbol-for-emacs? -- he -(defmethod inspect-for-emacs ((symbol symbol) (inspector t)) +(defmethod inspect-for-emacs ((symbol symbol) inspector) (declare (ignore inspector)) (let ((internal-external (multiple-value-bind (symbol status) (intern (symbol-name symbol) (symbol-package symbol)) @@ -2676,7 +2679,7 @@ " " (:action ,(format nil "[remove name ~S (does not affect class object)]" symbol) ,(lambda () (setf (find-class symbol) nil))))))) (values "A symbol." - `("Its name is: " (:value ,(symbol-name symbol)) +55 `("Its name is: " (:value ,(symbol-name symbol)) (:newline) ;; check to see whether it is a global variable, a ;; constant, or a symbol macro. @@ -2724,7 +2727,7 @@ , at package , at class)))) -(defmethod inspect-for-emacs ((f function) (inspector t)) +(defmethod inspect-for-emacs ((f function) inspector) (declare (ignore inspector)) (values "A function." `("Name: " (:value ,(function-name f)) (:newline) @@ -2764,7 +2767,7 @@ (swank-mop:generic-function-name (swank-mop:method-generic-function method)) (method-specializers-for-inspect method)))) -(defmethod inspect-for-emacs ((o standard-object) (inspector t)) +(defmethod inspect-for-emacs ((o standard-object) inspector) (declare (ignore inspector)) (values "An object." `("Class: " (:value ,(class-of o)) @@ -2851,7 +2854,7 @@ maxlen (length doc)))) -(defmethod inspect-for-emacs ((gf standard-generic-function) (inspector t)) +(defmethod inspect-for-emacs ((gf standard-generic-function) inspector) (declare (ignore inspector)) (values "A generic function." `("Name: " (:value ,(swank-mop:generic-function-name gf)) (:newline) @@ -2875,7 +2878,7 @@ collect (abbrev-doc (documentation method t)) and collect '(:newline))))) -(defmethod inspect-for-emacs ((method standard-method) (inspector t)) +(defmethod inspect-for-emacs ((method standard-method) inspector) (declare (ignore inspector)) (values "A method." `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) @@ -2894,7 +2897,7 @@ (:newline) "Method function: " (:value ,(swank-mop:method-function method))))) -(defmethod inspect-for-emacs ((class standard-class) (inspector t)) +(defmethod inspect-for-emacs ((class standard-class) inspector) (declare (ignore inspector)) (values "A class." `("Name: " (:value ,(class-name class)) @@ -2951,7 +2954,7 @@ `(:value ,(swank-mop:class-prototype class)) '"#")))) -(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) (inspector t)) +(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) inspector) (declare (ignore inspector)) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) @@ -2967,7 +2970,7 @@ "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline)))) -(defmethod inspect-for-emacs ((package package) (inspector t)) +(defmethod inspect-for-emacs ((package package) inspector) (declare (ignore inspector)) (let ((internal-symbols '()) (external-symbols '())) @@ -3010,7 +3013,7 @@ `(:value ,(package-shadowing-symbols package) ,(format nil "~D shadowed symbol~:P." (length (package-shadowing-symbols package))))))))) -(defmethod inspect-for-emacs ((pathname pathname) (inspector t)) +(defmethod inspect-for-emacs ((pathname pathname) inspector) (declare (ignore inspector)) (values (if (wild-pathname-p pathname) "A wild pathname." @@ -3027,7 +3030,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((pathname logical-pathname) (inspector t)) +(defmethod inspect-for-emacs ((pathname logical-pathname) inspector) (declare (ignore inspector)) (values "A logical pathname." (append @@ -3047,15 +3050,15 @@ ("Truename" (if (not (wild-pathname-p pathname)) (probe-file pathname))))))) -(defmethod inspect-for-emacs ((n number) (inspector t)) +(defmethod inspect-for-emacs ((n number) inspector) (declare (ignore inspector)) (values "A number." `("Value: " ,(princ-to-string n)))) -(defmethod inspect-for-emacs ((i integer) (inspector t)) +(defmethod inspect-for-emacs ((i integer) inspector) (declare (ignore inspector)) (values "A number." (append - `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8B = ~E" + `(,(format nil "Value: ~D = #x~X = #o~O = #b~:,,' ,8B = ~E" i i i i i) (:newline)) (if (< -1 i char-code-limit) @@ -3067,14 +3070,14 @@ (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0DZ" year month date hour min sec)))))) -(defmethod inspect-for-emacs ((c complex) (inspector t)) +(defmethod inspect-for-emacs ((c complex) inspector) (declare (ignore inspector)) (values "A complex number." (label-value-line* ("Real part" (realpart c)) ("Imaginary part" (imagpart c))))) -(defmethod inspect-for-emacs ((r ratio) (inspector t)) +(defmethod inspect-for-emacs ((r ratio) inspector) (declare (ignore inspector)) (values "A non-integer ratio." (label-value-line* @@ -3082,7 +3085,7 @@ ("Denominator" (denominator r)) ("As float" (float r))))) -(defmethod inspect-for-emacs ((f float) (inspector t)) +(defmethod inspect-for-emacs ((f float) inspector) (declare (ignore inspector)) (multiple-value-bind (significand exponent sign) (decode-float f) (values "A floating point number." From heller at common-lisp.net Tue Oct 26 00:32:09 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:32:09 +0200 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9732 Modified Files: swank-cmucl.lisp Log Message: (read-error-location, signal-compiler-condition): Handle read-errors. (swank-compile-file): Don't load the file if there was an error. Date: Tue Oct 26 02:32:08 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.124 slime/swank-cmucl.lisp:1.125 --- slime/swank-cmucl.lisp:1.124 Mon Oct 25 18:17:57 2004 +++ slime/swank-cmucl.lisp Tue Oct 26 02:32:08 2004 @@ -293,10 +293,11 @@ (with-compilation-hooks () (let ((*buffer-name* nil)) (multiple-value-bind (output-file warnings-p failure-p) - (compile-file filename :load load-p) + (compile-file filename) (unless failure-p ;; Cache the latest source file for definition-finding. - (source-cache-get filename (file-write-date filename))) + (source-cache-get filename (file-write-date filename)) + (load output-file)) (values output-file warnings-p failure-p))))) (defimplementation swank-compile-string (string &key buffer position directory) @@ -333,7 +334,9 @@ :severity (severity-for-emacs condition) :short-message (brief-compiler-message-for-emacs condition) :message (long-compiler-message-for-emacs condition context) - :location (compiler-note-location context)))) + :location (if (eq (type-of condition) 'c::compiler-read-error) + (read-error-location condition) + (compiler-note-location context))))) (defun severity-for-emacs (condition) "Return the severity of CONDITION." @@ -358,6 +361,18 @@ (c::compiler-error-context-source error-context))) (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A" enclosing source condition))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position pos))) + (t (break))))) (defun compiler-note-location (context) "Derive the location of a complier message from its context. From heller at common-lisp.net Tue Oct 26 00:33:13 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:33:13 +0200 Subject: [slime-cvs] CVS update: slime/swank-source-path-parser.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9814 Modified Files: swank-source-path-parser.lisp Log Message: Remove workarounds for SBCL bugs. The bugs are fixed in the versions we support. Date: Tue Oct 26 02:33:13 2004 Author: heller Index: slime/swank-source-path-parser.lisp diff -u slime/swank-source-path-parser.lisp:1.7 slime/swank-source-path-parser.lisp:1.8 --- slime/swank-source-path-parser.lisp:1.7 Fri Aug 13 22:32:33 2004 +++ slime/swank-source-path-parser.lisp Tue Oct 26 02:33:13 2004 @@ -22,6 +22,12 @@ (in-package :swank-backend) +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\\ rt)))) + (defun make-source-recorder (fn source-map) "Return a macro character function that does the same as FN, but additionally stores the result together with the stream positions @@ -36,70 +42,6 @@ (push (cons start end) (gethash (car values) source-map))) (values-list values)))) -#+sbcl -;; not sure why this should be the case, but SBCL 0.8.6 returns -;; # -;; for (get-macro-character) on characters that aren't macros. -;; As there's no way to detect the syntax of a character (only -;; to set it from another character) we have to compare against -;; this undefined-macro function to avoid turning everything into -;; a macro -- Dan Barlow -(if (not (get-macro-character #\space nil)) - (defun cmucl-style-get-macro-character (char table) - (get-macro-character char table)) - (defun cmucl-style-get-macro-character (char table) - (let ((rt (or table sb-impl::*standard-readtable*))) - (cond ((sb-impl::constituentp char) - (values (sb-impl::get-coerced-cmt-entry char rt) t)) - ((sb-impl::terminating-macrop char) - (values (sb-impl::get-coerced-cmt-entry char rt) nil)) - (t - (values nil nil)))))) - -#+cmu -(defun cmucl-style-get-macro-character (char table) - (get-macro-character char table)) - -;; Unlike CMUCL, SBCL stores NIL values into the character-macro-table -;; for constituent (in the CL sense) chars, and uses -;; get-coerced-cmt-entry to convert those NILs to #'read-token. In -;; CMUCL all constituents are also macro-chars. -;; -;; CMUCL and SBCL use a somewhat strange encoding for CL's Character -;; Syntax Types: -;; -;; CL Implementation -;; ---------------- -------------- -;; Constituent (constituentp x) i.e. (<= +char-attr-constituent+ x) -;; Macro Char (constituentp x) or +char-attr-terminating-macro+ -;; Single Escape +char-attr-escape+ -;; Invalid (constituentp x) with undefined-macro-char as fun -;; Multiple Escape +char-attr-multiple-escape+ -;; Whitespace +char-attr-whitespace+ -;; -;; One effect of this encoding is that invalid chars are not detected -;; inside tokens and it seems that there's no good way to distinguish -;; constituents from macro-chars. - -(defun dump-readtable (rt) - (dotimes (code char-code-limit) - (let ((char (code-char code))) - (multiple-value-bind (fn terminatingp) (get-macro-character char rt) - (format t "~S[~D]: ~12,1T~A ~A~%" - char code fn terminatingp))))) - -;; (dump-readtable *readtable*) - -(let ((rt (copy-readtable nil))) - ;; If #\space is a macro-char, it shouldn't terminate tokens. - (assert (or (not (cmucl-style-get-macro-character #\space rt)) - (nth-value 1 (cmucl-style-get-macro-character #\space rt)))) - ;; In SBCL (get-macro-character #\\) returns #'read-token, t. And - ;; (set-macro-character #\\ #'read-token t) confuses #'read-string, - ;; because it uses the attributes in the readtable for parsing - ;; decisions. - (assert (not (cmucl-style-get-macro-character #\\ rt)))) - (defun make-source-recording-readtable (readtable source-map) "Return a source position recording copy of READTABLE. The source locations are stored in SOURCE-MAP." @@ -107,8 +49,7 @@ (*readtable* tab)) (dotimes (code char-code-limit) (let ((char (code-char code))) - (multiple-value-bind (fn term) - (cmucl-style-get-macro-character char tab) + (multiple-value-bind (fn term) (get-macro-character char tab) (when fn (set-macro-character char (make-source-recorder fn source-map) term tab))))) From heller at common-lisp.net Tue Oct 26 00:35:36 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:35:36 +0200 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9846 Modified Files: swank-sbcl.lisp Log Message: (signal-compiler-condition): Remove reader conditionals as the current code doesn't work in any SBCL before 0.8.13 anyway. Date: Tue Oct 26 02:35:36 2004 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.105 slime/swank-sbcl.lisp:1.106 --- slime/swank-sbcl.lisp:1.105 Sun Oct 17 19:48:00 2004 +++ slime/swank-sbcl.lisp Tue Oct 26 02:35:36 2004 @@ -7,9 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties are ;;; disclaimed. -;;; This is a Slime backend for SBCL. Requires SBCL 0.8.5 or later -;;; for the SB-INTROSPECT contrib - +;;; Requires the SB-INTROSPECT contrib. ;;; Administrivia @@ -37,50 +35,7 @@ ;;; swank-mop -(import-to-swank-mop - '( ;; classes - cl:standard-generic-function - sb-mop::standard-slot-definition - cl:method - cl:standard-class - sb-mop:eql-specializer - ;; standard-class readers - sb-mop:class-default-initargs - sb-mop:class-direct-default-initargs - sb-mop:class-direct-slots - sb-mop:class-direct-subclasses - sb-mop:class-direct-superclasses - sb-mop:class-finalized-p - cl:class-name - sb-mop:class-precedence-list - sb-mop:class-prototype - sb-mop:class-slots - sb-mop:specializer-direct-methods - ;; eql-specializer accessors - sb-mop:eql-specializer-object - ;; generic function readers - sb-mop:generic-function-argument-precedence-order - sb-mop:generic-function-declarations - sb-mop:generic-function-lambda-list - sb-mop:generic-function-methods - sb-mop:generic-function-method-class - sb-mop:generic-function-method-combination - sb-mop:generic-function-name - ;; method readers - sb-mop:method-generic-function - sb-mop:method-function - sb-mop:method-lambda-list - sb-mop:method-specializers - sb-mop:method-qualifiers - ;; slot readers - sb-mop:slot-definition-allocation - sb-mop:slot-definition-initargs - sb-mop:slot-definition-initform - sb-mop:slot-definition-initfunction - sb-mop:slot-definition-name - sb-mop:slot-definition-type - sb-mop:slot-definition-readers - sb-mop:slot-definition-writers)) +(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) (defun swank-mop:slot-definition-documentation (slot) (sb-pcl::documentation slot t)) @@ -233,17 +188,11 @@ (error :error)) :short-message (brief-compiler-message-for-emacs condition) :references - ;; FIXME: delete the reader conditionaloid after sbcl - ;; 0.8.13 is released. - #+#.(cl:if (cl:find-symbol "ENCAPSULATED-CONDITION" "SB-INT") - '(and) '(or)) (let ((c (if (typep condition 'sb-int:encapsulated-condition) (sb-int:encapsulated-condition condition) condition))) (when (typep c 'sb-int:reference-condition) (sb-int:reference-condition-references c))) - #-#.(cl:if (cl:find-symbol "ENCAPSULATED-CONDITION" "SB-INT") - '(and) '(or)) (when (typep condition 'sb-int:reference-condition) (sb-int:reference-condition-references condition)) :message (long-compiler-message-for-emacs condition context) @@ -914,8 +863,6 @@ (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)) From heller at common-lisp.net Tue Oct 26 00:39:13 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:39:13 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9899 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Oct 26 02:39:12 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.556 slime/ChangeLog:1.557 --- slime/ChangeLog:1.556 Mon Oct 25 18:20:43 2004 +++ slime/ChangeLog Tue Oct 26 02:39:12 2004 @@ -1,3 +1,31 @@ +2004-10-26 Helmut Eller + + * swank-sbcl.lisp (signal-compiler-condition): Remove reader + conditionals as the current code doesn't work in any SBCL before + 0.8.13 anyway. + + * swank-source-path-parser.lisp: Remove workarounds for SBCL bugs. + The bugs are fixed in the versions we support. + + * swank-cmucl.lisp (read-error-location) + (signal-compiler-condition): Handle read-errors. + (swank-compile-file): Don't load the fasl file if there was an + error. + + * swank.lisp (define-printer-variables): Handle doc strings + properly. + (*sldb-pprint-dispatch*): Initialize it with the default dispatch + table. + + * slime.el (slime-init-command): New function to send the command + to load swank. Having a separate function for the task should + make it easier to start a Lips with a preloaded swank. + (slime-maybe-start-lisp): Use it. + (slime-maybe-start-multiprocessing): Deleted. + (slime-repl-buffer): Include the name of the implementation. + (slime-set-default-directory) + (slime-sync-package-and-default-directory): Translate filenames. + 2004-10-25 Marco Baringer * swank.lisp (inspect-for-emacs array): Properly deal with arrays From heller at common-lisp.net Tue Oct 26 00:43:42 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:43:42 +0200 Subject: [slime-cvs] CVS update: slime/cl-indent.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10071 Modified Files: cl-indent.el Log Message: (lisp-prefix-match-indentation): Change default to nil to avoid confusion for people who don't care about the issue. Add indentation specs for some missing CL symbols. Date: Tue Oct 26 02:43:42 2004 Author: heller Index: slime/cl-indent.el diff -u slime/cl-indent.el:1.1 slime/cl-indent.el:1.2 --- slime/cl-indent.el:1.1 Sun Oct 17 20:46:35 2004 +++ slime/cl-indent.el Tue Oct 26 02:43:42 2004 @@ -84,7 +84,7 @@ :type 'boolean :group 'lisp-indent) -(defcustom lisp-prefix-match-indentation nil +(defcustom lisp-prefix-match-indentation t "*Indent forms starting with \"def\" or \"do\" like defun or dolist." :type 'boolean :group 'lisp-indent) @@ -510,6 +510,7 @@ (define-setf-expander . defun) (defmacro . defun) (defsubst . defun) (deftype . defun) (defmethod lisp-indent-defmethod) + (defgeneric . defmethod) (defpackage (4 2)) (defstruct ((&whole 4 &rest (&whole 2 &rest 1)) &rest (&whole 2 &rest 1))) @@ -565,7 +566,15 @@ (with-output-to-string (4 2)) (with-slots . multiple-value-bind) (with-standard-io-syntax (2)) - (with-open-file (&lambda &body))))) + (with-open-file (&lambda &body)) + (with-open-stream (&lambda &body)) + (with-input-from-string (&lambda &body)) + (with-hash-table-iterator 1) + (with-compilation-unit (&lambda &body)) + (with-simple-restart (&lambda &body)) + (do-external-symbols (&lambda &body)) + (define-symbol-macro 1) + ))) (dolist (el l) (put (car el) 'common-lisp-indent-function (if (symbolp (cdr el)) From heller at common-lisp.net Tue Oct 26 00:45:38 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 26 Oct 2004 02:45:38 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10535 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Oct 26 02:45:36 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.557 slime/ChangeLog:1.558 --- slime/ChangeLog:1.557 Tue Oct 26 02:39:12 2004 +++ slime/ChangeLog Tue Oct 26 02:45:35 2004 @@ -1,5 +1,9 @@ 2004-10-26 Helmut Eller + * cl-indent.el: Add indentation specs for some missing CL symbols. + (lisp-prefix-match-indentation): Change default to + nil to avoid confusion for people who don't care about the issue. + * swank-sbcl.lisp (signal-compiler-condition): Remove reader conditionals as the current code doesn't work in any SBCL before 0.8.13 anyway. From heller at common-lisp.net Wed Oct 27 10:57:47 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 27 Oct 2004 12:57:47 +0200 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4614 Modified Files: swank-sbcl.lisp Log Message: (signal-compiler-condition): Actually delete one of the reader-conditionalized forms. Date: Wed Oct 27 12:57:46 2004 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.106 slime/swank-sbcl.lisp:1.107 --- slime/swank-sbcl.lisp:1.106 Tue Oct 26 02:35:36 2004 +++ slime/swank-sbcl.lisp Wed Oct 27 12:57:43 2004 @@ -17,8 +17,9 @@ (require 'sb-posix) ) -(declaim (optimize (debug 3))) + (in-package :swank-backend) +(declaim (optimize (debug 2))) (import '(sb-gray:fundamental-character-output-stream @@ -187,16 +188,15 @@ (warning :warning) (error :error)) :short-message (brief-compiler-message-for-emacs condition) - :references - (let ((c (if (typep condition 'sb-int:encapsulated-condition) - (sb-int:encapsulated-condition condition) - condition))) - (when (typep c 'sb-int:reference-condition) - (sb-int:reference-condition-references c))) - (when (typep condition 'sb-int:reference-condition) - (sb-int:reference-condition-references condition)) + :references (condition-references (real-condition condition)) :message (long-compiler-message-for-emacs condition context) :location (compiler-note-location context)))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) (defun compiler-note-location (context) (cond (context From heller at common-lisp.net Wed Oct 27 10:59:06 2004 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 27 Oct 2004 12:59:06 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4678 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Oct 27 12:59:06 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.558 slime/ChangeLog:1.559 --- slime/ChangeLog:1.558 Tue Oct 26 02:45:35 2004 +++ slime/ChangeLog Wed Oct 27 12:59:06 2004 @@ -1,3 +1,8 @@ +2004-10-27 Helmut Eller + + * swank-sbcl.lisp (signal-compiler-condition): Actually delete one + of the reader-conditionalized forms. + 2004-10-26 Helmut Eller * cl-indent.el: Add indentation specs for some missing CL symbols. From heller at common-lisp.net Thu Oct 28 21:21:57 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 28 Oct 2004 23:21:57 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15871 Modified Files: swank.lisp Log Message: (*sldb-stepping-p*): New variable. Used to tell emacs that the debugger buffer should not be closed even if we unwind. (debug-in-emacs): Use it. (sldb-step): Moved to the front end. (inspector-princ, method-specializers-for-inspect): Simplified. (methods-by-applicability): Use a simpler algorithm. I doubt there is much difference in practice. (inspect-for-emacs)[symbol, function, standard-generic-function] [standard-method]: Use less than 80 columns. (inspector-call-nth-action): Don't accept &rest args. Was never used. Date: Thu Oct 28 23:21:54 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.255 slime/swank.lisp:1.256 --- slime/swank.lisp:1.255 Tue Oct 26 02:30:47 2004 +++ slime/swank.lisp Thu Oct 28 23:21:53 2004 @@ -1363,6 +1363,9 @@ (defvar *sldb-restarts* nil "The list of currenlty active restarts.") +(defvar *sldb-stepping-p* nil + "True when during execution of a stepp command.") + ;; A set of printer variables used in the debugger. (define-printer-variables sldb-print (pretty nil) @@ -1380,6 +1383,7 @@ (symbol-value '*buffer-package*)) *package*)) (*sldb-level* (1+ *sldb-level*)) + (*sldb-stepping-p* nil) (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*))) (force-user-output) (with-printer-settings sldb-print @@ -1398,7 +1402,8 @@ *sldb-level*)) (handler-bind ((sldb-condition #'handle-sldb-condition)) (read-from-emacs)))))) - (send-to-emacs `(:debug-return ,(current-thread) ,level)))) + (send-to-emacs `(:debug-return + ,(current-thread) ,level ,*sldb-stepping-p*)))) (defun handle-sldb-condition (condition) "Handle an internal debugger condition. @@ -1546,6 +1551,14 @@ (with-buffer-syntax () (sldb-break-at-start (read-from-string name)))) +(defslimefun sldb-step (frame) + (cond ((find-restart 'continue) + (activate-stepping frame) + (setq *sldb-stepping-p* t) + (continue)) + (t + (error "No continue restart.")))) + ;;;; Compilation Commands. @@ -2534,7 +2547,8 @@ ;;;; Inspecting -(defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v)))) +(defun common-seperated-spec (list &optional (callback (lambda (v) + `(:value ,v)))) (butlast (loop for i in list @@ -2542,27 +2556,11 @@ collect ", "))) (defun inspector-princ (list) - "Just like princ-to-string, but don't rewrite (function foo) as - #'foo. Do NOT pass circular lists to this function." - (with-output-to-string (as-string) - (labels ((printer (object) - (typecase object - (null (princ nil as-string)) - (cons - (write-char #\( as-string) - (printer (car object)) - (loop - for (head . tail) on (cdr object) - do (write-char #\Space as-string) - do (printer head) - unless (listp tail) - do (progn - (write-string " . " as-string) - (printer tail)) - and return t) - (write-char #\) as-string)) - (t (princ object as-string))))) - (printer list)))) + "Like princ-to-string, but don't rewrite (function foo) as #'foo. +Do NOT pass circular lists to this function." + (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) + (set-pprint-dispatch '(cons (member function)) nil) + (princ-to-string list))) (defmethod inspect-for-emacs ((object cons) inspector) (declare (ignore inspector)) @@ -2663,80 +2661,93 @@ (:value ,*readtable*) ") it is a macro character: " (:value ,(get-macro-character char))))))) -;; Shouldn't most of this stuff be done by describe-symbol-for-emacs? -- he +(defun docstring-ispec (label object kind) + "Return a inspector spec if OBJECT has a docstring of of kind KIND." + (let ((docstring (documentation object kind))) + (cond ((not docstring) nil) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ": " '(:newline) " " docstring '(:newline)))))) + (defmethod inspect-for-emacs ((symbol symbol) inspector) (declare (ignore inspector)) - (let ((internal-external (multiple-value-bind (symbol status) - (intern (symbol-name symbol) (symbol-package symbol)) - (declare (ignore symbol)) - (ecase status - ((:internal :inherited) :internal) - (:external :external)))) - (package (when (find-package symbol) - `("It names the package " (:value ,(find-package symbol)) (:newline)))) - (class (when (find-class symbol nil) - `("It names the class " (:value ,(find-class symbol) ,(inspector-princ (class-name (find-class symbol)))) - " " (:action ,(format nil "[remove name ~S (does not affect class object)]" symbol) - ,(lambda () (setf (find-class symbol) nil))))))) - (values "A symbol." -55 `("Its name is: " (:value ,(symbol-name symbol)) - (:newline) - ;; check to see whether it is a global variable, a - ;; constant, or a symbol macro. - ,@(let ((documentation (when (documentation symbol 'variable) - `((:newline) - "Documentation:" - (:newline) - ,(documentation symbol 'variable))))) - (cond - ((constantp symbol) - `("It is a constant of value: " (:value ,(symbol-value symbol)) , at documentation)) - ((boundp symbol) - `("It is a global variable bound to: " (:value ,(symbol-value symbol)) , at documentation)) - ((nth-value 1 (macroexpand symbol)) - `("It is a symbol macro with expansion: " (:value ,(macroexpand symbol)))) - (t - `("It is unbound.")))) - (:newline) - ,@(if (fboundp symbol) - (append - (if (macro-function symbol) - `("It a macro with macro-function: " (:value ,(macro-function symbol))) - `("It is a function: " (:value ,(symbol-function symbol)))) - `(" " (:action "[make funbound]" ,(lambda () (fmakunbound symbol)))) - `((:newline)) - (when (documentation symbol 'function) - `("Documentation:" (:newline) ,(documentation symbol 'function) (:newline))) - (when (compiler-macro-function symbol) - `("It also names the compiler macro: " (:value ,(compiler-macro-function symbol)) (:newline))) - (when (documentation symbol 'compiler-macro) - `("Documentation:" (:newline) ,(documentation symbol 'compiler-macro) (:newline)))) - `("It has no function value." (:newline))) - "It is " ,(case internal-external - (:internal "internal") - (:external "external")) " to the package: " (:value ,(symbol-package symbol)) - ,@(when (eql :internal internal-external) - `(" " (:action ,(with-output-to-string (export-label) - (princ "[export from " export-label) - (princ (package-name (symbol-package symbol)) export-label) - (princ "]" export-label)) - ,(lambda () (export symbol (symbol-package symbol)))))) - (:newline) - "Property list: " (:value ,(symbol-plist symbol)) - (:newline) - , at package - , at class)))) + (let ((package (symbol-package symbol))) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) + (declare (ignore _symbol)) + (values + "A symbol." + (append + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; Value + (cond ((boundp symbol) + (label-value-line (if (constantp symbol) + "It is a constant of value" + "It is a global variable bound to") + (symbol-value symbol))) + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[make funbound]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function Documentation" symbol 'function) + (if (compiler-macro-function symbol) + (label-value-line "It also names the compiler macro" + (compiler-macro-function symbol))) + (docstring-ispec "Compiler Macro Documentation" + symbol 'compiler-macro) + ;; + ;; Package + `("It is " ,(string-downcase (string status)) " to the package: " + (:value ,package ,(package-name package)) + ,@(if (eq :internal status) + `((:action " [export it]" + ,(lambda () (export symbol package))))) + (:newline)) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) + (:action " [remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + ))))) (defmethod inspect-for-emacs ((f function) inspector) (declare (ignore inspector)) (values "A function." - `("Name: " (:value ,(function-name f)) (:newline) - "Its argument list is: " ,(inspector-princ (arglist f)) - (:newline) - ,@(when (function-lambda-expression f) - `("Lambda Expression: " (:value ,(function-lambda-expression f)) (:newline))) - ,@(when (documentation f t) - `("Documentation:" (:newline) ,(documentation f t) (:newline)))))) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(inspector-princ (arglist f)) (:newline)) + (docstring-ispec "Documentation" f t) + (if (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f)))))) (defun method-specializers-for-inspect (method) "Return a \"pretty\" list of the method's specializers. Normal @@ -2755,17 +2766,10 @@ specialiazed on, the second element is the method qualifiers, the rest of the list is the method's specialiazers (as per method-specializers-for-inspect)." - (if (swank-mop:method-qualifiers method) - (list* - (swank-mop:generic-function-name (swank-mop:method-generic-function method)) - (let ((quals (swank-mop:method-qualifiers method))) - (if (= 1 (length quals)) - (first quals) - quals)) - (method-specializers-for-inspect method)) - (list* - (swank-mop:generic-function-name (swank-mop:method-generic-function method)) - (method-specializers-for-inspect method)))) + (append (list (swank-mop:generic-function-name + (swank-mop:method-generic-function method))) + (swank-mop:method-qualifiers method) + (method-specializers-for-inspect method))) (defmethod inspect-for-emacs ((o standard-object) inspector) (declare (ignore inspector)) @@ -2798,96 +2802,69 @@ The default returns the method sorted by applicability. See `methods-by-applicability'.") -;;; Largely inspired by (+ copied from) the McCLIM listener +(defun specializer< (specializer1 specializer2) + "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." + (let ((s1 specializer1) (s2 specializer2) ) + (cond ((typep s1 'swank-mop:eql-specializer) + (not (typep s2 'swank-mop:eql-specializer))) + (t + (flet ((cpl (class) + (and (swank-mop:class-finalized-p class) + (swank-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) + (defun methods-by-applicability (gf) - "Return methods ordered by qualifiers, then by most specific argument types. + "Return methods ordered by most specific argument types. -Qualifier ordering is: :before, :around, primary, and :after. -We use the length of the class precedence list to determine which type is -more specific." - ;;FIXME: How to deal with argument-precedence-order? +`method-specializer<' is used for sorting." + ;; FIXME: argument-precedence-order and qualifiers are ignored. (let ((methods (copy-list (swank-mop:generic-function-methods gf)))) - ;; sorter function (most specific is defined as smaller) - (flet ((method< (meth1 meth2) - ;; First ordering rule is by qualifiers, that is :before-methods - ;; come before :around methods, before primary methods, before - ;; :after methods, other qualifiers are treated like none at all - ;; (so like primary methods) - (let ((qualifier-order '(:before :around nil :after))) - (let ((q1 (or (position (first (swank-mop:method-qualifiers meth1)) qualifier-order) 2)) - (q2 (or (position (first (swank-mop:method-qualifiers meth2)) qualifier-order) 2))) - (cond ((< q1 q2) (return-from method< t)) - ((> q1 q2) (return-from method< nil))))) - ;; If qualifiers are equal, go by arguments - (loop for sp1 in (swank-mop:method-specializers meth1) - for sp2 in (swank-mop:method-specializers meth2) - do (cond - ((eq sp1 sp2)) ;; continue comparision - ;; an eql specializer is most specific - ((typep sp1 'swank-mop:eql-specializer) - (return-from method< t)) - ((typep sp2 'swank-mop:eql-specializer) - (return-from method< nil)) - ;; otherwise the longer the CPL the more specific - ;; the specializer is - ;; FIXME: Taking the CPL as indicator has the problem - ;; that unfinalized classes are most specific. Can we pick - ;; a reasonable default or do something with SUBTYPEP ? - (t (let ((l1 (if (swank-mop:class-finalized-p sp1) - (length (swank-mop:class-precedence-list sp1)) - 0)) - (l2 (if (swank-mop:class-finalized-p sp2) - (length (swank-mop:class-precedence-list sp2)) - 0))) - (cond - ((> l1 l2) - (return-from method< t)) - ((< l1 l2) - (return-from method< nil)))))) - finally (return nil)))) - (declare (dynamic-extent #'method<)) - (sort methods #'method<)))) + (labels ((method< (meth1 meth2) + (loop for s1 in (swank-mop:method-specializers meth1) + for s2 in (swank-mop:method-specializers meth2) + do (cond ((specializer< s2 s1) (return nil)) + ((specializer< s1 s2) (return t)))))) + (stable-sort methods #'method<)))) (defun abbrev-doc (doc &optional (maxlen 80)) "Return the first sentence of DOC, but not more than MAXLAN characters." (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) - maxlen - (length doc)))) + maxlen + (length doc)))) (defmethod inspect-for-emacs ((gf standard-generic-function) inspector) (declare (ignore inspector)) - (values "A generic function." - `("Name: " (:value ,(swank-mop:generic-function-name gf)) (:newline) - "Its argument list is: " ,(inspector-princ (swank-mop:generic-function-lambda-list gf)) (:newline) - "Documentation: " (:newline) - ,(inspector-princ (documentation gf t)) (:newline) - "Its method class is: " (:value ,(swank-mop:generic-function-method-class gf)) (:newline) - "It uses " (:value ,(swank-mop:generic-function-method-combination gf)) " method combination." (:newline) - "Methods: " (:newline) - ,@(loop - for method in (funcall *gf-method-getter* gf) - collect `(:value ,method ,(inspector-princ - ;; drop the first element (the name of the generic function) - (cdr (method-for-inspect-value method)))) - collect " " - collect (let ((meth method)) - `(:action "[remove method]" ,(lambda () (remove-method gf meth)))) - collect '(:newline) - if (documentation method t) - collect " Documentation: " and - collect (abbrev-doc (documentation method t)) and - collect '(:newline))))) + (flet ((lv (label value) (label-value-line label value))) + (values + "A generic function." + (append + (lv "Name" (swank-mop:generic-function-name gf)) + (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) + (docstring-ispec "Documentation" gf t) + (lv "Method class" (swank-mop:generic-function-method-class gf)) + (lv "Method combination" + (swank-mop:generic-function-method-combination gf)) + `("Methods: " (:newline)) + (loop for method in (funcall *gf-method-getter* gf) append + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) + (:action " [remove method]" + ,(let ((m method)) ; LOOP reassigns method + (lambda () + (remove-method gf m)))) + (:newline))))))) (defmethod inspect-for-emacs ((method standard-method) inspector) (declare (ignore inspector)) (values "A method." - `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) - ,(inspector-princ - (swank-mop:generic-function-name - (swank-mop:method-generic-function method)))) + `("Method defined on the generic function " + (:value ,(swank-mop:method-generic-function method) + ,(inspector-princ + (swank-mop:generic-function-name + (swank-mop:method-generic-function method)))) (:newline) - ,@(when (documentation method t) - `("Documentation:" (:newline) ,(documentation method t) (:newline))) + ,@(docstring-ispec "Documentation" method t) "Lambda List: " (:value ,(swank-mop:method-lambda-list method)) (:newline) "Specializers: " (:value ,(swank-mop:method-specializers method) @@ -3172,8 +3149,8 @@ (with-buffer-syntax () (inspect-object (inspector-nth-part index)))) -(defslimefun inspector-call-nth-action (index &rest args) - (apply (aref *inspectee-actions* index) args) +(defslimefun inspector-call-nth-action (index) + (funcall (aref *inspectee-actions* index)) (inspect-object (pop *inspector-stack*))) (defslimefun inspector-pop () @@ -3419,6 +3396,6 @@ (add-hook *pre-reply-hook* 'sync-indentation-to-emacs) -;;; 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: +;; 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 Thu Oct 28 21:23:10 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 28 Oct 2004 23:23:10 +0200 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15909 Modified Files: swank-backend.lisp Log Message: (activate-stepping): New function. Date: Thu Oct 28 23:23:10 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.70 slime/swank-backend.lisp:1.71 --- slime/swank-backend.lisp:1.70 Thu Sep 23 23:19:52 2004 +++ slime/swank-backend.lisp Thu Oct 28 23:23:10 2004 @@ -514,8 +514,8 @@ (:SHOW-FRAME-SOURCE frame-number)" '()) -(definterface sldb-step (frame-number) - "Step to the next code location in the frame FRAME-NUMBER.") +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") (definterface sldb-break-on-return (frame-number) "Set a breakpoint in the frame FRAME-NUMBER.") From heller at common-lisp.net Thu Oct 28 21:28:17 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 28 Oct 2004 23:28:17 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15964 Modified Files: slime.el Log Message: (slime-dispatch-event): Accept stepping flag. (slime-space): Call slime-message in the right buffer, so that after-command hooks are added in the right buffer. Reported by Juho Snellman. (sldb-setup): Don't query when entering a recursive edit. (sldb-exit): Don't kill the buffer if we are in stepping mode. (slime-inspector-insert-ispec): New function. (slime-open-inspector): Use it. (slime-inspector-operate-on-point): Simplified. (test interactive-eval): Fix test case. Date: Thu Oct 28 23:28:16 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.414 slime/slime.el:1.415 --- slime/slime.el:1.414 Tue Oct 26 02:28:16 2004 +++ slime/slime.el Thu Oct 28 23:28:16 2004 @@ -2094,9 +2094,9 @@ ((:debug thread level condition restarts frames) (assert thread) (sldb-setup thread level condition restarts frames)) - ((:debug-return thread level) + ((:debug-return thread level &optional stepping) (assert thread) - (sldb-exit thread level)) + (sldb-exit thread level stepping)) ((:emacs-interrupt thread) (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint)) (t (slime-send `(:emacs-interrupt ,thread))))) @@ -3689,8 +3689,10 @@ (values start (point)) (values (1+ start) (progn (goto-char (1+ start)) - (forward-sexp 1) - (point)))))))) + (or (ignore-errors + (forward-sexp 1) + (point)) + (+ start 2))))))))) (defun slime-same-line-p (pos1 pos2) "Return t if buffer positions POS1 and POS2 are on the same line." @@ -4045,9 +4047,11 @@ (when names (slime-eval-async `(swank:arglist-for-echo-area (quote ,names)) - (lambda (message) - (if message - (slime-message "%s" message))))))) + (lexical-let ((buffer (current-buffer))) + (lambda (message) + (if message + (with-current-buffer buffer + (slime-message "%s" message))))))))) (self-insert-command n))) (defun slime-arglist (name) @@ -5799,7 +5803,9 @@ (pop-to-buffer (current-buffer)) (setq buffer-read-only t) (when (and slime-stack-eval-tags - (y-or-n-p "Enter recursive edit? ")) + ;; (y-or-n-p "Enter recursive edit? ") + ) + (message "Entering recursive edit..") (recursive-edit))))) (defun sldb-activate (thread level) @@ -5810,14 +5816,15 @@ (lambda (result) (apply #'sldb-setup thread level result))))))) -(defun sldb-exit (thread level) +(defun sldb-exit (thread level &optional stepping) (when-let (sldb (sldb-find-buffer thread)) (with-current-buffer sldb - (set-window-configuration sldb-saved-window-configuration) + (unless stepping + (set-window-configuration sldb-saved-window-configuration)) (let ((inhibit-read-only t)) (erase-buffer)) (setq sldb-level nil)) - (when (= level 1) + (when (and (= level 1) (not stepping)) (setf sldb-buffers (remove* sldb sldb-buffers :key #'cdr)) (kill-buffer sldb)))) @@ -6594,43 +6601,48 @@ (with-current-buffer (slime-inspector-buffer) (let ((inhibit-read-only t)) (erase-buffer) - (destructuring-bind (&key title type content) - inspected-parts - (macrolet ((fontify (face string) `(slime-inspector-fontify ,face ,string))) + (destructuring-bind (&key title type content) inspected-parts + (macrolet ((fontify (face string) + `(slime-inspector-fontify ,face ,string))) (insert (fontify topline title)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n [" (fontify label "type:") " " (fontify type type) "]\n" (fontify label "--------------------") "\n") - (save-excursion - (loop for part in content - do (if (stringp part) - (insert part) - (ecase (car part) - (:value - (destructuring-bind (string id) (cdr part) - (slime-propertize-region `(slime-part-number ,id) - (insert (fontify value string))))) - (:action - (destructuring-bind (string id) (cdr part) - (slime-propertize-region `(slime-action-number ,id) - (insert (fontify action string))))))))) - (pop-to-buffer (current-buffer)) - (when point (goto-char point)))) - t))) + (save-excursion + (mapc #'slime-inspector-insert-ispec content)) + (pop-to-buffer (current-buffer)) + (when point + (goto-char (min (point-max) point)))))))) + +(defun slime-inspector-insert-ispec (ispec) + (if (stringp ispec) + (insert ispec) + (destructure-case ispec + ((:value string id) + (slime-insert-propertized (list 'slime-part-number id + 'face 'slime-inspector-value-face) + string)) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'face 'slime-inspector-action-face) + string))))) (defun slime-inspector-operate-on-point () "If point is on a value then recursivly call the inspcetor on that value. If point is on an action then call that action." (interactive) - (cond - ((get-text-property (point) 'slime-part-number) - (slime-eval-async `(swank:inspect-nth-part ,(get-text-property (point) 'slime-part-number)) - 'slime-open-inspector) - (push (point) slime-inspector-mark-stack)) - ((get-text-property (point) 'slime-action-number) - (slime-eval-async `(swank::inspector-call-nth-action ,(get-text-property (point) 'slime-action-number)) - 'slime-open-inspector)))) + (let ((part-number (get-text-property (point) 'slime-part-number)) + (action-number (get-text-property (point) 'slime-action-number))) + (cond (part-number + (slime-eval-async `(swank:inspect-nth-part ,part-number) + 'slime-open-inspector) + (push (point) slime-inspector-mark-stack)) + (action-number + (slime-eval-async `(swank::inspector-call-nth-action ,action-number) + (lexical-let ((point (point))) + (lambda (parts) + (slime-open-inspector parts point)))))))) (defun slime-inspector-copy-down (number) "Evaluate the slot at point via the REPL (to set `*')." @@ -7542,7 +7554,7 @@ (slime-check-top-level) (let ((message (current-message))) (slime-check "Minibuffer contains: \"3\"" - (equal "3" message)))))) + (equal "3 (#x3, #o3, #b11)" message)))))) (def-slime-test interrupt-bubbling-idiot () From heller at common-lisp.net Thu Oct 28 21:34:37 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 28 Oct 2004 23:34:37 +0200 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16974 Modified Files: swank-cmucl.lisp Log Message: (set-step-breakpoints): Handle breakpoints at single-return points in escaped frames better. Previously we tried to set a breakpoint at the current position and consequently was only hit during the next call. (inspect-for-emacs)[function]: Call the next method only for funcallable instances. (profile-report, profile-reset, unprofile-all): We have to use eval because the macro expansion depends on the value of *timed-functions*. Reported by Chisheng Huang. Date: Thu Oct 28 23:34:36 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.125 slime/swank-cmucl.lisp:1.126 --- slime/swank-cmucl.lisp:1.125 Tue Oct 26 02:32:08 2004 +++ slime/swank-cmucl.lisp Thu Oct 28 23:34:36 2004 @@ -1573,12 +1573,8 @@ (t (format nil "Cannot return from frame: ~S" frame)))) "return-from-frame is not implemented in this version of CMUCL."))) -(defimplementation sldb-step (frame) - (cond ((find-restart 'continue) - (set-step-breakpoints (nth-frame frame)) - (continue)) - (t - (error "No continue restart.")))) +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) (defimplementation sldb-break-on-return (frame) (break-on-return (nth-frame frame))) @@ -1605,18 +1601,40 @@ "Return true if the frame pointers of FRAME1 and FRAME2 are the same." (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + (defun set-step-breakpoints (frame) (let ((cl (di:frame-code-location frame))) (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) (error "Cannot step in elsewhere code")) - (let* ((debug::*bad-code-location-types* + (let* ((debug::*bad-code-location-types* (remove :call-site debug::*bad-code-location-types*)) - (next (debug::next-code-locations cl))) + (next (next-code-locations frame cl))) (cond (next (let ((steppoints '())) (flet ((hook (bp-frame bp) - (mapc #'di:delete-breakpoint steppoints) - (signal-breakpoint bp bp-frame))) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) (dolist (code-location next) (let ((bp (di:make-breakpoint #'hook code-location :kind :code-location))) @@ -1874,29 +1892,30 @@ (defmethod inspect-for-emacs :around ((o function) (inspector cmucl-inspector)) (declare (ignore inspector)) - (multiple-value-bind (title contents) - (call-next-method) - (let ((header (kernel:get-type o))) - (cond ((= header vm:function-header-type) - (values (format nil "~A is a function." o) - (append contents - (label-value-line* - ("Self" (kernel:%function-self o)) - ("Next" (kernel:%function-next o)) - ("Type" (kernel:%function-type o)) - ("Code" (kernel:function-code-header o))) - (list - (with-output-to-string (s) - (disassem:disassemble-function o :stream s)))))) - ((= header vm:closure-header-type) - (values (format nil "~A is a closure" o) - (append - (label-value-line "Function Object" (kernel:%closure-function o)) - `("Environment:" (:newline)) - (loop - for i from 0 below (1- (kernel:get-closure-length o)) - append (label-value-line i (kernel:%closure-index-ref o i)))))) - (t (values title contents)))))) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (values (format nil "~A is a function." o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (values (format nil "~A is a closure" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + (t + (call-next-method))))) + (defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector)) (declare (ignore _)) @@ -1945,14 +1964,14 @@ (eval `(profile:unprofile ,fname))) (defimplementation unprofile-all () - (profile:unprofile) + (eval `(profile:unprofile)) "All functions unprofiled.") (defimplementation profile-report () - (profile:report-time)) + (eval `(profile:report-time))) (defimplementation profile-reset () - (profile:reset-time) + (eval `(profile:reset-time)) "Reset profiling counters.") (defimplementation profiled-functions () From heller at common-lisp.net Thu Oct 28 21:37:19 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 28 Oct 2004 23:37:19 +0200 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17001 Modified Files: slime.el Log Message: (slime-kill-all-buffers): More regexp kludges. From Bill Clementson. Date: Thu Oct 28 23:37:18 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.415 slime/slime.el:1.416 --- slime/slime.el:1.415 Thu Oct 28 23:28:16 2004 +++ slime/slime.el Thu Oct 28 23:37:18 2004 @@ -3107,7 +3107,7 @@ (dolist (buf (buffer-list)) (when (or (string= (buffer-name buf) slime-event-buffer-name) (string-match "^\\*inferior-lisp*" (buffer-name buf)) - (string-match "^\\*slime-repl\\[[0-9]+\\]\\*$" (buffer-name buf)) + (string-match "^\\*slime-repl .*\\*$" (buffer-name buf)) (string-match "^\\*sldb .*\\*$" (buffer-name buf))) (kill-buffer buf)))) From heller at common-lisp.net Thu Oct 28 21:39:36 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 28 Oct 2004 23:39:36 +0200 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17044 Modified Files: swank-clisp.lisp Log Message: Add workaround for CLISP's broken control string parser. Date: Thu Oct 28 23:39:36 2004 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.39 slime/swank-clisp.lisp:1.40 --- slime/swank-clisp.lisp:1.39 Sun Oct 3 14:27:53 2004 +++ slime/swank-clisp.lisp Thu Oct 28 23:39:36 2004 @@ -492,6 +492,239 @@ (invoke-debugger condition))))) nil)) +(in-package :system) + +#.(setf (ext:package-lock :system) nil) + +(ext:without-package-lock () + +;; Patch buggy format parser. ~:,D was not parsed correcly. +(defun format-parse-cs (control-string startindex csdl stop-at) + (declare (fixnum startindex)) + (macrolet ((errorstring () + (TEXT "The control string terminates within a format directive."))) + (prog* ((index startindex) ; cs-index of the next character + ch ; current character + intparam ; Integer-Parameter + newcsd ; current CSD + (last-separator-csd (car csdl))) + (declare (type simple-string control-string) (type fixnum index)) + (loop ; new directive altogether + (tagbody + (when (>= index (length control-string)) + (go string-ended)) + (setq ch (schar control-string index)) + (unless (eql ch #\~) + ;; possibly transform part of string into a separate directive, + (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd))))) + (setf (csd-type newcsd) 1) + (setf (csd-cs-index newcsd) index) + (setq index (position #\~ control-string :start index)) + (unless index + (setf (csd-data newcsd) (setq index (length control-string))) + (go string-ended)) + (setf (csd-data newcsd) index)) + (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd))))) + (setf (csd-type newcsd) 2) + (setf (csd-cs-index newcsd) index) + (setf (csd-parm-list newcsd) nil) + (setf (csd-v-or-#-p newcsd) nil) + (setf (csd-colon-p newcsd) nil) + (setf (csd-atsign-p newcsd) nil) + (setf (csd-data newcsd) nil) + (setf (csd-clause-chain newcsd) nil) + + param ; parameter of a directive may begin + (incf index) + (when (>= index (length control-string)) + (format-error control-string index (errorstring)) + (go string-ended)) + (setq ch (schar control-string index)) + (when (digit-char-p ch) (go num-param)) + (case ch + ((#\+ #\-) (go num-param)) + (#\' (go quote-param)) + ((#\V #\v #\#) + (push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG) + (csd-parm-list newcsd)) + (setf (csd-v-or-#-p newcsd) T) + (go param-ok-1)) + (#\, (push nil (csd-parm-list newcsd)) (go param)) + (#\: (go colon-modifier)) + (#\@ (go atsign-modifier)) + (T (go directive))) + + num-param ; numerical parameter + (multiple-value-setq (intparam index) + (parse-integer control-string :start index :junk-allowed t)) + (unless intparam + (format-error control-string index + (TEXT "~A must introduce a number.") + ch)) + (push intparam (csd-parm-list newcsd)) + (go param-ok-2) + + quote-param ; Quote-Parameter-Treatment + (incf index) + (when (>= index (length control-string)) + (format-error control-string index + (TEXT "The control string terminates in the middle of a parameter.")) + (go string-ended)) + (setq ch (schar control-string index)) + (push ch (csd-parm-list newcsd)) + + param-ok-1 ; Parameter OK + (incf index) + param-ok-2 ; Parameter OK + (when (>= index (length control-string)) + (format-error control-string index (errorstring)) + (go string-ended)) + (setq ch (schar control-string index)) + (case ch + (#\, (go param)) + (#\: (go colon-modifier)) + (#\@ (go atsign-modifier)) + (T (go directive))) + + colon-modifier ; after : + (when (csd-colon-p newcsd) + (format-error control-string index + (TEXT "Too many colon modifiers supplied"))) + (setf (csd-colon-p newcsd) T) + (go param) + + atsign-modifier ; after @ + (when (csd-colon-p newcsd) + (format-error control-string index + (TEXT "Too many at modifiers supplied"))) + (setf (csd-atsign-p newcsd) T) + (go param) + + directive ; directive (its Name) reached + (setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd))) + (let ((directive-name + (cdr (assoc (char-upcase ch) + ; with function-definition ; without function-definition + '((#\A . FORMAT-ASCII) + (#\S . FORMAT-S-EXPRESSION) + (#\W . FORMAT-WRITE) + (#\D . FORMAT-DECIMAL) + (#\B . FORMAT-BINARY) + (#\O . FORMAT-OCTAL) + (#\X . FORMAT-HEXADECIMAL) + (#\R . FORMAT-RADIX) + (#\P . FORMAT-PLURAL) + (#\C . FORMAT-CHARACTER) + (#\F . FORMAT-FIXED-FLOAT) + (#\E . FORMAT-EXPONENTIAL-FLOAT) + (#\G . FORMAT-GENERAL-FLOAT) + (#\$ . FORMAT-DOLLARS-FLOAT) + (#\% . FORMAT-TERPRI) + (#\_ . FORMAT-PPRINT-NEWLINE) + (#\I . FORMAT-PPRINT-INDENT) + (#\& . FORMAT-FRESH-LINE) (#\Newline . #\Newline) + (#\| . FORMAT-PAGE) + (#\~ . FORMAT-TILDE) + (#\T . FORMAT-TABULATE) + (#\* . FORMAT-GOTO) + (#\? . FORMAT-INDIRECTION) + (#\/ . FORMAT-CALL-USER-FUNCTION) + (#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END) + (#\[ . FORMAT-CONDITIONAL) (#\] . FORMAT-CONDITIONAL-END) + (#\{ . FORMAT-ITERATION) (#\} . FORMAT-ITERATION-END) + (#\< . FORMAT-JUSTIFICATION) (#\> . FORMAT-JUSTIFICATION-END) + (#\^ . FORMAT-UP-AND-OUT) (#\; . FORMAT-SEPARATOR) + (#\! . FORMAT-CALL)))))) + (if directive-name + (setf (csd-data newcsd) directive-name) + (format-error control-string index + (TEXT "Non-existent format directive")))) + (incf index) + (case ch + (#\/ + (let* ((start index) + (end (or (position #\/ control-string :start start) + (format-error control-string index + (TEXT "Closing '/' is missing")))) + (pos (position #\: control-string :start start :end end)) + (name (string-upcase + (subseq control-string + (if pos + (if (char= #\: (char control-string (1+ pos))) (+ 2 pos) (1+ pos)) + start) + end))) + (pack (if pos + (let ((packname + (string-upcase + (subseq control-string start pos)))) + (or (find-package packname) + (format-error control-string index + (TEXT "There is no package with name ~S") + packname))) + *common-lisp-user-package*))) + (push (list (intern name pack)) (csd-parm-list newcsd)) + (setq index (1+ end)))) + (( #\( #\[ #\{) + (multiple-value-setq (index csdl) + (format-parse-cs control-string index csdl + (case ch (#\( #\)) (#\[ #\]) (#\{ #\}) )))) + (#\< + (multiple-value-setq (index csdl) + (format-parse-cs control-string index csdl #\>)) + ;; (assert (eq (csd-data (car csdl)) 'FORMAT-JUSTIFICATION-END)) + (when (csd-colon-p (car csdl)) + (setf (csd-data newcsd) 'FORMAT-LOGICAL-BLOCK))) + (( #\) #\] #\} #\> ) + (unless stop-at + (format-error control-string index + (TEXT "The closing format directive '~A' does not have a corresponding opening one.") + ch)) + (unless (eql ch stop-at) + (format-error control-string index + (TEXT "The closing format directive '~A' does not match the corresponding opening one. It should read '~A'.") + ch stop-at)) + (setf (csd-clause-chain last-separator-csd) csdl) + (go end)) + (#\; + (unless (or (eql stop-at #\]) (eql stop-at #\>)) + (format-error control-string index + (TEXT "The ~~; format directive is not allowed at this point."))) + (setf (csd-clause-chain last-separator-csd) csdl) + (setq last-separator-csd newcsd)) + (#\Newline + (setf (csd-type newcsd) 0) + (if (csd-colon-p newcsd) + (if (csd-atsign-p newcsd) + (format-error control-string index + (TEXT "The ~~newline format directive cannot take both modifiers.")) + nil) ; ~: -> ignore Newline, retain Whitespace + (progn + (when (csd-atsign-p newcsd) + ;; ~@ -> part of String with Newline for output + (setf (csd-type newcsd) 1) + (setf (csd-cs-index newcsd) (1- index)) + (setf (csd-data newcsd) index)) + (setq index + (or (position-if-not #'whitespacep control-string :start index) + (length control-string))))))) + ) ; tagbody finished + ) ; loop finished + + string-ended + (when stop-at + (format-error control-string index + (TEXT "An opening format directive is never closed; expecting '~A'.") + stop-at)) + + end + (return (values index csdl))))) + +) + +#.(setf (ext:package-lock :system) t) + +(in-package :swank-backend) + ;;; Inspecting (defclass clisp-inspector (inspector) From heller at common-lisp.net Thu Oct 28 21:41:39 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 28 Oct 2004 23:41:39 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17092 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Oct 28 23:41:38 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.559 slime/ChangeLog:1.560 --- slime/ChangeLog:1.559 Wed Oct 27 12:59:06 2004 +++ slime/ChangeLog Thu Oct 28 23:41:38 2004 @@ -1,3 +1,45 @@ +2004-10-28 Helmut Eller + + * swank-clisp.lisp: Add workaround for CLISP's broken control + string parser. + + * swank-cmucl.lisp (set-step-breakpoints): Handle breakpoints at + single-return points in escaped frames better. Previously we + tried to set a breakpoint at the current position and consequently + was only hit during the next call. + (inspect-for-emacs)[function]: Call the next method only for + funcallable instances. + (profile-report, profile-reset, unprofile-all): We have to use + eval because the macro expansion depends on the value of + *timed-functions*. Reported by Chisheng Huang. + + * slime.el (slime-space): Call slime-message in the right buffer, + so that after-command hooks are added in the right buffer. + Reported by Juho Snellman. + (slime-dispatch-event): Accept stepping flag. + (sldb-setup): Don't query when entering a recursive edit. + (sldb-exit): Don't kill the buffer if we are in stepping mode. + (slime-inspector-insert-ispec): New function. + (slime-open-inspector): Use it. + (slime-inspector-operate-on-point): Simplified. + (test interactive-eval): Fix test case. + (slime-kill-all-buffers): More regexp kludges. From Bill Clementson. + + * swank-backend.lisp (activate-stepping): New function. + + * swank.lisp (*sldb-stepping-p*): New variable. Used to tell + emacs that the debugger buffer should not be closed even if we + unwind. + (debug-in-emacs): Use it. + (sldb-step): Moved to the front end. + (inspector-princ, method-specializers-for-inspect): Simplified. + (methods-by-applicability): Use a simpler algorithm. I doubt there + is much difference in practice. + (inspect-for-emacs)[symbol, function, standard-generic-function] + [standard-method]: Use less than 80 columns. + (inspector-call-nth-action): Don't accept &rest args. Was never + used. + 2004-10-27 Helmut Eller * swank-sbcl.lisp (signal-compiler-condition): Actually delete one From heller at common-lisp.net Thu Oct 28 22:12:23 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 29 Oct 2004 00:12:23 +0200 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20102 Modified Files: swank-clisp.lisp Log Message: Undo previous change. Date: Fri Oct 29 00:12:23 2004 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.40 slime/swank-clisp.lisp:1.41 --- slime/swank-clisp.lisp:1.40 Thu Oct 28 23:39:36 2004 +++ slime/swank-clisp.lisp Fri Oct 29 00:12:22 2004 @@ -492,238 +492,6 @@ (invoke-debugger condition))))) nil)) -(in-package :system) - -#.(setf (ext:package-lock :system) nil) - -(ext:without-package-lock () - -;; Patch buggy format parser. ~:,D was not parsed correcly. -(defun format-parse-cs (control-string startindex csdl stop-at) - (declare (fixnum startindex)) - (macrolet ((errorstring () - (TEXT "The control string terminates within a format directive."))) - (prog* ((index startindex) ; cs-index of the next character - ch ; current character - intparam ; Integer-Parameter - newcsd ; current CSD - (last-separator-csd (car csdl))) - (declare (type simple-string control-string) (type fixnum index)) - (loop ; new directive altogether - (tagbody - (when (>= index (length control-string)) - (go string-ended)) - (setq ch (schar control-string index)) - (unless (eql ch #\~) - ;; possibly transform part of string into a separate directive, - (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd))))) - (setf (csd-type newcsd) 1) - (setf (csd-cs-index newcsd) index) - (setq index (position #\~ control-string :start index)) - (unless index - (setf (csd-data newcsd) (setq index (length control-string))) - (go string-ended)) - (setf (csd-data newcsd) index)) - (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd))))) - (setf (csd-type newcsd) 2) - (setf (csd-cs-index newcsd) index) - (setf (csd-parm-list newcsd) nil) - (setf (csd-v-or-#-p newcsd) nil) - (setf (csd-colon-p newcsd) nil) - (setf (csd-atsign-p newcsd) nil) - (setf (csd-data newcsd) nil) - (setf (csd-clause-chain newcsd) nil) - - param ; parameter of a directive may begin - (incf index) - (when (>= index (length control-string)) - (format-error control-string index (errorstring)) - (go string-ended)) - (setq ch (schar control-string index)) - (when (digit-char-p ch) (go num-param)) - (case ch - ((#\+ #\-) (go num-param)) - (#\' (go quote-param)) - ((#\V #\v #\#) - (push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG) - (csd-parm-list newcsd)) - (setf (csd-v-or-#-p newcsd) T) - (go param-ok-1)) - (#\, (push nil (csd-parm-list newcsd)) (go param)) - (#\: (go colon-modifier)) - (#\@ (go atsign-modifier)) - (T (go directive))) - - num-param ; numerical parameter - (multiple-value-setq (intparam index) - (parse-integer control-string :start index :junk-allowed t)) - (unless intparam - (format-error control-string index - (TEXT "~A must introduce a number.") - ch)) - (push intparam (csd-parm-list newcsd)) - (go param-ok-2) - - quote-param ; Quote-Parameter-Treatment - (incf index) - (when (>= index (length control-string)) - (format-error control-string index - (TEXT "The control string terminates in the middle of a parameter.")) - (go string-ended)) - (setq ch (schar control-string index)) - (push ch (csd-parm-list newcsd)) - - param-ok-1 ; Parameter OK - (incf index) - param-ok-2 ; Parameter OK - (when (>= index (length control-string)) - (format-error control-string index (errorstring)) - (go string-ended)) - (setq ch (schar control-string index)) - (case ch - (#\, (go param)) - (#\: (go colon-modifier)) - (#\@ (go atsign-modifier)) - (T (go directive))) - - colon-modifier ; after : - (when (csd-colon-p newcsd) - (format-error control-string index - (TEXT "Too many colon modifiers supplied"))) - (setf (csd-colon-p newcsd) T) - (go param) - - atsign-modifier ; after @ - (when (csd-colon-p newcsd) - (format-error control-string index - (TEXT "Too many at modifiers supplied"))) - (setf (csd-atsign-p newcsd) T) - (go param) - - directive ; directive (its Name) reached - (setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd))) - (let ((directive-name - (cdr (assoc (char-upcase ch) - ; with function-definition ; without function-definition - '((#\A . FORMAT-ASCII) - (#\S . FORMAT-S-EXPRESSION) - (#\W . FORMAT-WRITE) - (#\D . FORMAT-DECIMAL) - (#\B . FORMAT-BINARY) - (#\O . FORMAT-OCTAL) - (#\X . FORMAT-HEXADECIMAL) - (#\R . FORMAT-RADIX) - (#\P . FORMAT-PLURAL) - (#\C . FORMAT-CHARACTER) - (#\F . FORMAT-FIXED-FLOAT) - (#\E . FORMAT-EXPONENTIAL-FLOAT) - (#\G . FORMAT-GENERAL-FLOAT) - (#\$ . FORMAT-DOLLARS-FLOAT) - (#\% . FORMAT-TERPRI) - (#\_ . FORMAT-PPRINT-NEWLINE) - (#\I . FORMAT-PPRINT-INDENT) - (#\& . FORMAT-FRESH-LINE) (#\Newline . #\Newline) - (#\| . FORMAT-PAGE) - (#\~ . FORMAT-TILDE) - (#\T . FORMAT-TABULATE) - (#\* . FORMAT-GOTO) - (#\? . FORMAT-INDIRECTION) - (#\/ . FORMAT-CALL-USER-FUNCTION) - (#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END) - (#\[ . FORMAT-CONDITIONAL) (#\] . FORMAT-CONDITIONAL-END) - (#\{ . FORMAT-ITERATION) (#\} . FORMAT-ITERATION-END) - (#\< . FORMAT-JUSTIFICATION) (#\> . FORMAT-JUSTIFICATION-END) - (#\^ . FORMAT-UP-AND-OUT) (#\; . FORMAT-SEPARATOR) - (#\! . FORMAT-CALL)))))) - (if directive-name - (setf (csd-data newcsd) directive-name) - (format-error control-string index - (TEXT "Non-existent format directive")))) - (incf index) - (case ch - (#\/ - (let* ((start index) - (end (or (position #\/ control-string :start start) - (format-error control-string index - (TEXT "Closing '/' is missing")))) - (pos (position #\: control-string :start start :end end)) - (name (string-upcase - (subseq control-string - (if pos - (if (char= #\: (char control-string (1+ pos))) (+ 2 pos) (1+ pos)) - start) - end))) - (pack (if pos - (let ((packname - (string-upcase - (subseq control-string start pos)))) - (or (find-package packname) - (format-error control-string index - (TEXT "There is no package with name ~S") - packname))) - *common-lisp-user-package*))) - (push (list (intern name pack)) (csd-parm-list newcsd)) - (setq index (1+ end)))) - (( #\( #\[ #\{) - (multiple-value-setq (index csdl) - (format-parse-cs control-string index csdl - (case ch (#\( #\)) (#\[ #\]) (#\{ #\}) )))) - (#\< - (multiple-value-setq (index csdl) - (format-parse-cs control-string index csdl #\>)) - ;; (assert (eq (csd-data (car csdl)) 'FORMAT-JUSTIFICATION-END)) - (when (csd-colon-p (car csdl)) - (setf (csd-data newcsd) 'FORMAT-LOGICAL-BLOCK))) - (( #\) #\] #\} #\> ) - (unless stop-at - (format-error control-string index - (TEXT "The closing format directive '~A' does not have a corresponding opening one.") - ch)) - (unless (eql ch stop-at) - (format-error control-string index - (TEXT "The closing format directive '~A' does not match the corresponding opening one. It should read '~A'.") - ch stop-at)) - (setf (csd-clause-chain last-separator-csd) csdl) - (go end)) - (#\; - (unless (or (eql stop-at #\]) (eql stop-at #\>)) - (format-error control-string index - (TEXT "The ~~; format directive is not allowed at this point."))) - (setf (csd-clause-chain last-separator-csd) csdl) - (setq last-separator-csd newcsd)) - (#\Newline - (setf (csd-type newcsd) 0) - (if (csd-colon-p newcsd) - (if (csd-atsign-p newcsd) - (format-error control-string index - (TEXT "The ~~newline format directive cannot take both modifiers.")) - nil) ; ~: -> ignore Newline, retain Whitespace - (progn - (when (csd-atsign-p newcsd) - ;; ~@ -> part of String with Newline for output - (setf (csd-type newcsd) 1) - (setf (csd-cs-index newcsd) (1- index)) - (setf (csd-data newcsd) index)) - (setq index - (or (position-if-not #'whitespacep control-string :start index) - (length control-string))))))) - ) ; tagbody finished - ) ; loop finished - - string-ended - (when stop-at - (format-error control-string index - (TEXT "An opening format directive is never closed; expecting '~A'.") - stop-at)) - - end - (return (values index csdl))))) - -) - -#.(setf (ext:package-lock :system) t) - -(in-package :swank-backend) ;;; Inspecting From heller at common-lisp.net Thu Oct 28 22:14:12 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 29 Oct 2004 00:14:12 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20148 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Oct 29 00:14:11 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.560 slime/ChangeLog:1.561 --- slime/ChangeLog:1.560 Thu Oct 28 23:41:38 2004 +++ slime/ChangeLog Fri Oct 29 00:14:11 2004 @@ -1,5 +1,7 @@ 2004-10-28 Helmut Eller + * swank-clisp.lisp: Ups. Undo previous change. + * swank-clisp.lisp: Add workaround for CLISP's broken control string parser. From heller at common-lisp.net Thu Oct 28 22:16:16 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 29 Oct 2004 00:16:16 +0200 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20585 Modified Files: swank.lisp Log Message: (inspect-for-emacs[integer]): Fix control string. Thanks to CSR for pointing it out. Date: Fri Oct 29 00:16:02 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.256 slime/swank.lisp:1.257 --- slime/swank.lisp:1.256 Thu Oct 28 23:21:53 2004 +++ slime/swank.lisp Fri Oct 29 00:16:01 2004 @@ -3035,7 +3035,7 @@ (declare (ignore inspector)) (values "A number." (append - `(,(format nil "Value: ~D = #x~X = #o~O = #b~:,,' ,8B = ~E" + `(,(format nil "Value: ~D = #x~X = #o~O = #b~,,' ,8:B = ~E" i i i i i) (:newline)) (if (< -1 i char-code-limit) From heller at common-lisp.net Thu Oct 28 22:19:04 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 29 Oct 2004 00:19:04 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21156 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Oct 29 00:19:03 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.561 slime/ChangeLog:1.562 --- slime/ChangeLog:1.561 Fri Oct 29 00:14:11 2004 +++ slime/ChangeLog Fri Oct 29 00:19:03 2004 @@ -41,6 +41,8 @@ [standard-method]: Use less than 80 columns. (inspector-call-nth-action): Don't accept &rest args. Was never used. + (inspect-for-emacs) [integer]: Fix control string. Thanks to CSR + for pointing it out. 2004-10-27 Helmut Eller From heller at common-lisp.net Sat Oct 30 10:16:31 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 30 Oct 2004 12:16:31 +0200 Subject: [slime-cvs] CVS update: slime/swank-source-path-parser.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6196 Modified Files: swank-source-path-parser.lisp Log Message: (source-path-stream-position): Bind *read-suppress* only as long as we skip over forms. The last toplevel form in the path is read with *read-suppress* = nil because in newer versions of CMUCL and SBCL read will return nil if *read-suppress* is t. Date: Sat Oct 30 12:16:30 2004 Author: heller Index: slime/swank-source-path-parser.lisp diff -u slime/swank-source-path-parser.lisp:1.8 slime/swank-source-path-parser.lisp:1.9 --- slime/swank-source-path-parser.lisp:1.8 Tue Oct 26 02:33:13 2004 +++ slime/swank-source-path-parser.lisp Sat Oct 30 12:16:29 2004 @@ -63,17 +63,17 @@ Return the object together with a hashtable that maps subexpressions of the object to stream positions." (let* ((*source-map* (make-hash-table :test #'eq)) - (*readtable* (make-source-recording-readtable *readtable* *source-map*))) + (*readtable* (make-source-recording-readtable *readtable* + *source-map*))) (values (read stream) *source-map*))) (defun source-path-stream-position (path stream) "Search the source-path PATH in STREAM and return its position." (destructuring-bind (tlf-number . path) path (let ((*read-suppress* t)) - (dotimes (i tlf-number) (read stream)) - (multiple-value-bind (form source-map) - (read-and-record-source-map stream) - (source-path-source-position (cons 0 path) form source-map))))) + (dotimes (i tlf-number) (read stream))) + (multiple-value-bind (form source-map) (read-and-record-source-map stream) + (source-path-source-position (cons 0 path) form source-map)))) (defun source-path-string-position (path string) (with-input-from-string (s string) From heller at common-lisp.net Sat Oct 30 10:21:55 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 30 Oct 2004 12:21:55 +0200 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6385 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Oct 30 12:21:54 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.562 slime/ChangeLog:1.563 --- slime/ChangeLog:1.562 Fri Oct 29 00:19:03 2004 +++ slime/ChangeLog Sat Oct 30 12:21:54 2004 @@ -1,3 +1,11 @@ +2004-10-30 Helmut Eller + + * swank-source-path-parser.lisp (source-path-stream-position): + Bind *read-suppress* only as long as we skip over forms. The last + toplevel form in the path is read with *read-suppress* = nil + because in newer versions of CMUCL and SBCL read will return nil + if *read-suppress* is t. + 2004-10-28 Helmut Eller * swank-clisp.lisp: Ups. Undo previous change.