From heller at common-lisp.net Fri Jun 10 17:51:33 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 10 Jun 2005 19:51:33 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050610175133.C883F880AC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25737 Modified Files: slime.el Log Message: (slime-with-xref-buffer): Gensym package too, to avoid problems when switching to buffers with -*- package: ... -*- file variables. From Antonio Menezes Leitao. (slime-property-bounds): Use the prop argument instead of the hardcoded 'slime-repl-old-output. From Andras Simon. Date: Fri Jun 10 19:51:33 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.506 slime/slime.el:1.507 --- slime/slime.el:1.506 Fri Jun 3 22:00:11 2005 +++ slime/slime.el Fri Jun 10 19:51:32 2005 @@ -3202,13 +3202,14 @@ ;; forward one char to avoid doing the wrong thing if ;; we're at the beginning of the old input. -luke ;; (18/Jun/2004) - (unless (not (get-text-property (point) 'slime-repl-old-output)) - ;alanr unless we are sitting right after it May 19, 2005 + (unless (not (get-text-property (point) prop)) + ;; alanr unless we are sitting right after it May 19, 2005 (ignore-errors (forward-char))) (previous-single-char-property-change (point) prop))) (end (save-excursion - (if (get-text-property (point) 'slime-repl-old-output) - (progn (goto-char (next-single-char-property-change (point) prop)) + (if (get-text-property (point) prop) + (progn (goto-char (next-single-char-property-change + (point) prop)) (skip-chars-backward "\n \t\r" beg) (point)) (point))))) @@ -3923,7 +3924,6 @@ (funcall predicate))) (buffer-list))) - ;;;;; Merging together compiler notes in the same location. @@ -6306,14 +6306,12 @@ (defmacro* slime-with-xref-buffer ((package ref-type symbol) &body body) "Execute BODY in a xref buffer, then show that buffer." - (let ((type (gensym)) - (sym (gensym))) - `(let ((,type ,ref-type) - (,sym ,symbol)) + (let ((type (gensym)) (sym (gensym)) (pkg (gensym))) + `(let ((,type ,ref-type) (,sym ,symbol) (,pgk ,package)) (with-current-buffer (get-buffer-create (format "*XREF[%s: %s]*" ,type ,sym)) (prog2 (progn - (slime-init-xref-buffer ,package ,type ,sym) + (slime-init-xref-buffer ,pgk ,type ,sym) (make-local-variable 'slime-xref-saved-window-configuration) (setq slime-xref-saved-window-configuration (current-window-configuration))) From heller at common-lisp.net Fri Jun 10 17:54:01 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 10 Jun 2005 19:54:01 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/nregex.lisp Message-ID: <20050610175401.A0F87880AC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25776 Modified Files: nregex.lisp Log Message: Rename package to avoid name clashes with other version of this file. Date: Fri Jun 10 19:54:01 2005 Author: heller Index: slime/nregex.lisp diff -u slime/nregex.lisp:1.2 slime/nregex.lisp:1.3 --- slime/nregex.lisp:1.2 Mon Apr 26 14:30:18 2004 +++ slime/nregex.lisp Fri Jun 10 19:54:00 2005 @@ -26,8 +26,11 @@ (in-package :cl-user) +;; Renamed to slime-nregex avoid name clashes with other versions of +;; this file. -- he + ;;;; CND - 6/3/2001 -(defpackage nregex +(defpackage slime-nregex (:use #:common-lisp) (:export #:regex @@ -35,7 +38,7 @@ )) ;;;; CND - 6/3/2001 -(in-package :nregex) +(in-package :slime-nregex) ;;; ;;; First we create a copy of macros to help debug the beast From heller at common-lisp.net Fri Jun 10 17:54:23 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 10 Jun 2005 19:54:23 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050610175423.497FB880AC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25806 Modified Files: swank.lisp Log Message: (compiled-regex): Use the new package name. Date: Fri Jun 10 19:54:22 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.305 slime/swank.lisp:1.306 --- slime/swank.lisp:1.305 Wed Jun 1 14:41:02 2005 +++ slime/swank.lisp Fri Jun 10 19:54:22 2005 @@ -2953,7 +2953,7 @@ (setf (gethash regex-string regex-hash) (if (zerop (length regex-string)) (lambda (s) (check-type s string) t) - (compile nil (nregex:regex-compile regex-string))))))) + (compile nil (slime-nregex:regex-compile regex-string))))))) (defun apropos-matcher (string case-sensitive package external-only) (let* ((case-modifier (if case-sensitive #'string #'string-upcase)) From heller at common-lisp.net Fri Jun 10 17:55:11 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 10 Jun 2005 19:55:11 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050610175511.94607880AC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25847 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jun 10 19:55:10 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.709 slime/ChangeLog:1.710 --- slime/ChangeLog:1.709 Tue Jun 7 12:08:04 2005 +++ slime/ChangeLog Fri Jun 10 19:55:10 2005 @@ -1,3 +1,16 @@ +2005-06-10 Helmut Eller + + * nregex.lisp (slime-nregex): Rename package to avoid name clashes + with other version of this file. + + * swank.lisp (compiled-regex): Use the new package name. + + * slime.el (slime-with-xref-buffer): Gensym package too, to avoid + problems when switching to buffers with -*- package: ... -*- file + variables. From Antonio Menezes Leitao. + (slime-property-bounds): Use the prop argument instead of the + hardcoded 'slime-repl-old-output. From Andras Simon. + 2005-06-07 Espen Wiborg * swank-corman.lisp: Convert to Unix line-endings. From nsiivola at common-lisp.net Sat Jun 11 16:22:25 2005 From: nsiivola at common-lisp.net (Nikodemus Siivola) Date: Sat, 11 Jun 2005 18:22:25 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank-sbcl.lisp Message-ID: <20050611162225.D626B8816A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11444 Modified Files: ChangeLog swank-sbcl.lisp Log Message: Changes for supporting recent SBCLs. Date: Sat Jun 11 18:22:23 2005 Author: nsiivola Index: slime/ChangeLog diff -u slime/ChangeLog:1.710 slime/ChangeLog:1.711 --- slime/ChangeLog:1.710 Fri Jun 10 19:55:10 2005 +++ slime/ChangeLog Sat Jun 11 18:22:23 2005 @@ -1,3 +1,14 @@ +2005-06-11 Nikodemus Siivola + + * swank-sbcl.lisp: Patched for SBCL HEAD: utilize the new + :source-plist functionality; maintain compatibility with 0.9.1 + till 0.9.2 is out. Removed cruft left over from previous + excercises in supporting both HEAD and latest release. + + * doc/slime.texi: Document Slime as supporting the latest official + release of SBCL, as opposed to a specific version number which + would need to be updated monthly. + 2005-06-10 Helmut Eller * nregex.lisp (slime-nregex): Rename package to avoid name clashes Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.133 slime/swank-sbcl.lisp:1.134 --- slime/swank-sbcl.lisp:1.133 Wed Jun 1 14:22:45 2005 +++ slime/swank-sbcl.lisp Sat Jun 11 18:22:23 2005 @@ -14,6 +14,11 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-bsd-sockets) (require 'sb-introspect) + ;; KLUDGE: Support for 0.9.1 and older concurrently with 0.9.1.25 + ;; and newer -- the #-swank-backend::source-plist cases can be + ;; deleted after SBCL 0.9.2 has been released. + (when (find-symbol "DEFINITION-SOURCE-PLIST" :sb-introspect) + (pushnew 'swank-backend::source-plist *features*)) (require 'sb-posix)) (in-package :swank-backend) @@ -290,7 +295,9 @@ (list :error "No error location available"))) (defun locate-compiler-note (file source-path source) - (cond ((and (pathnamep file) *buffer-name*) + (cond ((and #+swank-backend::source-plist (eq file :lisp) + #-swank-backend::source-plist (pathnamep file) + *buffer-name*) ;; Compiling from a buffer (let ((position (+ *buffer-offset* (source-path-string-position @@ -370,59 +377,89 @@ ;;;; compile-string -;;; We patch sb-c::debug-source-for-info so that we can dump our own -;;; bits of source info. Our *user-source-info* is stored in the -;;; debug-source-info slot. - -(defvar *real-debug-source-for-info*) -(defvar *user-source-info*) +#-swank-backend::source-plist +(progn + ;; We patch sb-c::debug-source-for-info so that we can dump our own + ;; bits of source info. Our *user-source-info* is stored in the + ;; debug-source-info slot. + (defvar *real-debug-source-for-info*) + (defvar *user-source-info*) -(defun debug-source-for-info-advice (info) - (destructuring-bind (source) (funcall *real-debug-source-for-info* info) - (when (boundp '*user-source-info*) - (setf (sb-c::debug-source-info source) *user-source-info*)) - (list source))) - -(defun install-debug-source-patch () - (unless (boundp '*real-debug-source-for-info*) - (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info)) - (sb-ext:without-package-locks - (setf (symbol-function 'sb-c::debug-source-for-info) - #'debug-source-for-info-advice))) + (defun debug-source-for-info-advice (info) + (destructuring-bind (source) (funcall *real-debug-source-for-info* info) + (when (boundp '*user-source-info*) + (setf (sb-c::debug-source-info source) *user-source-info*)) + (list source))) + + (defun install-debug-source-patch () + (unless (boundp '*real-debug-source-for-info*) + (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info)) + (sb-ext:without-package-locks + (setf (symbol-function 'sb-c::debug-source-for-info) + #'debug-source-for-info-advice))) + + (defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (install-debug-source-patch) + (call/temp-file + string + (lambda (filename) + (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string + :emacs-position position)) + (*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string)) + (let ((fasl (with-compilation-hooks () + (compile-file filename)))) + (load fasl) + (delete-file fasl)))))) + + (defun call/temp-file (string fun) + (let ((filename (temp-file-name))) + (unwind-protect + (with-open-file (s filename :direction :output :if-exists :error) + (write-string string s) + (finish-output s) + (funcall fun filename)) + (when (probe-file filename) + (delete-file filename))))) + + (defun temp-file-name () + "Return a temporary file name to compile strings into." + (sb-alien:alien-funcall + (sb-alien:extern-alien + "tmpnam" + (function sb-alien:c-string sb-alien:system-area-pointer)) + (sb-sys:int-sap 0))) + + (defun find-temp-function-source-location (function) + (let ((info (function-debug-source-info function))) + (with-struct (sb-introspect::definition-source- + form-path character-offset) + (sb-introspect:find-definition-source function) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info + (let ((pos (if form-path + (with-debootstrapping + (source-path-string-position + form-path emacs-string)) + character-offset))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ pos emacs-position)) + `(:snippet ,emacs-string)))))))) +#+swank-backend::source-plist (defimplementation swank-compile-string (string &key buffer position directory) (declare (ignore directory)) - (install-debug-source-patch) - (call/temp-file - string - (lambda (filename) - (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string - :emacs-position position)) - (*buffer-name* buffer) - (*buffer-offset* position) - (*buffer-substring* string)) - (let ((fasl (with-compilation-hooks () - (compile-file filename)))) - (load fasl) - (delete-file fasl)))))) - -(defun call/temp-file (string fun) - (let ((filename (temp-file-name))) - (unwind-protect - (with-open-file (s filename :direction :output :if-exists :error) - (write-string string s) - (finish-output s) - (funcall fun filename)) - (when (probe-file filename) - (delete-file filename))))) - -(defun temp-file-name () - "Return a temporary file name to compile strings into." - (sb-alien:alien-funcall - (sb-alien:extern-alien - "tmpnam" - (function sb-alien:c-string sb-alien:system-area-pointer)) - (sb-sys:int-sap 0))) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string)) + (with-compilation-hooks () + (with-compilation-unit (:source-plist + (list :emacs-buffer buffer + :emacs-string string + :emacs-position position)) + (with-input-from-string (s string) + (load s)))))) ;;;; Definitions @@ -464,6 +501,7 @@ ;;; the position of the first code-location; for some reason, that ;;; doesn't seem to work.) +#-swank-backend::source-plist (defun function-source-location (function &optional name) "Try to find the canonical source location of FUNCTION." (declare (type function function)) @@ -471,6 +509,12 @@ (find-temp-function-source-location function) (find-function-source-location function))) +#+swank-backend::source-plist +(defun function-source-location (function &optional name) + "Try to find the canonical source location of FUNCTION." + (declare (type function function)) + (find-function-source-location function)) + (defun safe-function-source-location (fun name) (if *debug-definition-finding* (function-source-location fun name) @@ -478,6 +522,7 @@ (error (e) (list :error (format nil "Error: ~A" e)))))) +#-swank-backend::source-plist (defun find-function-source-location (function) (cond #+(or) ;; doesn't work for unknown reasons ((function-has-start-location-p function) @@ -491,6 +536,33 @@ `(:position ,pos) `(:snippet ,snippet)))))) +#+swank-backend::source-plist +(defun find-function-source-location (function) + (with-struct (sb-introspect::definition-source- form-path character-offset plist) + (sb-introspect:find-definition-source function) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist + (if emacs-buffer + (let ((pos (if form-path + (with-debootstrapping + (source-path-string-position + form-path emacs-string)) + character-offset))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ pos emacs-position)) + `(:snippet ,emacs-string))) + (cond #+(or) + ;; doesn't work for unknown reasons + ((function-has-start-location-p function) + (code-location-source-location (function-start-location function))) + ((not (function-source-filename function)) + (error "Source filename not recorded for ~A" function)) + (t + (let* ((pos (function-source-position function)) + (snippet (function-hint-snippet function pos))) + (make-location `(:file ,(function-source-filename function)) + `(:position ,pos) + `(:snippet ,snippet))))))))) + (defun function-source-position (function) ;; We only consider the toplevel form number here. (let* ((tlf (function-toplevel-form-number function)) @@ -507,8 +579,8 @@ (sb-introspect:find-definition-source function)))))) (defun function-source-write-date (function) - (definition-source-file-write-date - (sb-introspect:find-definition-source function))) + (sb-introspect:definition-source-file-write-date + (sb-introspect:find-definition-source function))) (defun function-toplevel-form-number (function) (car @@ -528,27 +600,6 @@ (let ((dfun (sb-di:fun-debug-fun function))) (and dfun (sb-di:debug-fun-start-location dfun)))) -(defun find-temp-function-source-location (function) - (let ((info (function-debug-source-info function))) - (with-struct (sb-introspect::definition-source- - form-path character-offset) - (sb-introspect:find-definition-source function) - (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info - (let ((pos (if form-path - (with-debootstrapping - (source-path-string-position - form-path emacs-string)) - character-offset))) - (make-location `(:buffer ,emacs-buffer) - `(:position ,(+ pos emacs-position)) - `(:snippet ,emacs-string))))))) - -;; FIXME: Symbol doesn't exist in released SBCL (0.8.20) yet. -(defun definition-source-file-write-date (def) - (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE" - (find-package "SB-INTROSPECT")))) - (when sym (funcall sym def)))) - (defun method-definitions (gf) (let ((methods (sb-mop:generic-function-methods gf)) (name (sb-mop:generic-function-name gf))) @@ -692,26 +743,7 @@ collect f))) (defimplementation print-frame (frame stream) - (macrolet ((printer-form () - ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style - ;; our usage of unexported interfaces came back to haunt - ;; us. And since we still use the same interfaces it will - ;; haunt us again. - (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug))) - (if (fboundp print-sym) - (let* ((args (sb-introspect:function-arglist print-sym)) - (key-pos (position '&key args))) - (cond ((eql 2 key-pos) - `(,print-sym frame stream)) - ((eql 1 key-pos) - `(let ((*standard-output* stream)) - (,print-sym frame))) - (t - (error "*THWAP* SBCL changes internals ~ - again!")))) - (error "You're in a twisty little maze of unsupported - SBCL interfaces, all different."))))) - (printer-form))) + (sb-debug::print-frame-call frame stream)) ;;;; Code-location -> source-location translation @@ -721,12 +753,33 @@ ;;; If there's no debug-block info, we return the (less precise) ;;; source-location of the corresponding function. +#-swank-backend::source-plist (defun code-location-source-location (code-location) (let ((dsource (sb-di:code-location-debug-source code-location))) (ecase (sb-di:debug-source-from dsource) (:file (file-source-location code-location)) (:lisp (lisp-source-location code-location))))) +#+swank-backend::source-plist +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource))) + (if (getf plist :emacs-buffer) + (emacs-buffer-source-location code-location plist) + (ecase (sb-di:debug-source-from dsource) + (:file (file-source-location code-location)) + (:lisp (lisp-source-location code-location)))))) + +;;; FIXME: The naming policy of source-location functions is a bit +;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the +;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co +;;; which returns the source location for a _code-location_. +;;; +;;; Maybe these should be named code-location-file-source-location, +;;; etc, turned into generic functions, or something. In the very least the names +;;; should indicate the main entry point vs. helper status. + +#-swank-backend::source-plist (defun file-source-location (code-location) (cond ((code-location-has-debug-block-info-p code-location) (if (code-location-from-emacs-buffer-p code-location) @@ -738,11 +791,23 @@ (t (error "Cannot find source location for: ~A " code-location))))))) +#+swank-backend::source-plist +(defun file-source-location (code-location) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + (defun lisp-source-location (code-location) - (let ((source (with-output-to-string (*standard-output*) - (print-code-location-source-form code-location 100)))) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100)))) (make-location `(:source-form ,source) '(:position 0)))) +#-swank-backend::source-plist (defun temp-file-source-location (code-location) (let ((info (code-location-debug-source-info code-location))) (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info @@ -753,6 +818,18 @@ `(:position ,(+ emacs-position pos)) `(:snippet ,snipped)))))) +#+swank-backend::source-plist +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (with-input-from-string (s emacs-string) + (read-snippet s pos)))) + (make-location `(:buffer ,emacs-buffer) + `(:position ,(+ emacs-position pos)) + `(:snippet ,snipped)))) + (fallback-source-location code-location))) + (defun source-file-source-location (code-location) (let* ((code-date (code-location-debug-source-created code-location)) (filename (code-location-debug-source-name code-location)) @@ -764,8 +841,27 @@ `(:position ,(1+ pos)) `(:snippet ,snippet)))))) -(defun code-location-debug-source-info (code-location) - (sb-c::debug-source-info (sb-di::code-location-debug-source code-location))) +#-swank-backend::source-plist +(progn + (defun code-location-debug-source-info (code-location) + (sb-c::debug-source-info (sb-di::code-location-debug-source code-location))) + + (defun code-location-from-emacs-buffer-p (code-location) + (info-from-emacs-buffer-p (code-location-debug-source-info code-location))) + + (defun function-from-emacs-buffer-p (function) + (info-from-emacs-buffer-p (function-debug-source-info function))) + + (defun function-debug-source-info (function) + (let* ((comp (sb-di::compiled-debug-fun-component + (sb-di::fun-debug-fun function)))) + (sb-c::debug-source-info (car (sb-c::debug-info-source + (sb-kernel:%code-debug-info comp)))))) + + (defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info))))) (defun code-location-debug-source-name (code-location) (sb-c::debug-source-name (sb-di::code-location-debug-source code-location))) @@ -777,23 +873,6 @@ (defun code-location-debug-fun-fun (code-location) (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) -(defun code-location-from-emacs-buffer-p (code-location) - (info-from-emacs-buffer-p (code-location-debug-source-info code-location))) - -(defun function-from-emacs-buffer-p (function) - (info-from-emacs-buffer-p (function-debug-source-info function))) - -(defun function-debug-source-info (function) - (let* ((comp (sb-di::compiled-debug-fun-component - (sb-di::fun-debug-fun function)))) - (sb-c::debug-source-info (car (sb-c::debug-info-source - (sb-kernel:%code-debug-info comp)))))) - -(defun info-from-emacs-buffer-p (info) - (and info - (consp info) - (eq :emacs-buffer (car info)))) - (defun code-location-has-debug-block-info-p (code-location) (handler-case (progn (sb-di:code-location-debug-block code-location) @@ -818,30 +897,6 @@ (stream-source-position code-location s))) ;;; source-path-file-position and friends are in swank-source-path-parser - -(defun print-code-location-source-form (code-location context) - (macrolet ((printer-form () - ;; KLUDGE: These are both unexported interfaces, used - ;; by different versions of SBCL. ...sooner or later - ;; this will change again: hopefully by then we have - ;; figured out the interface we want to drive the - ;; debugger with and requested it from the SBCL - ;; folks. - (let ((print-code-sym - (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM" - :sb-debug)) - (code-sym - (find-symbol "CODE-LOCATION-SOURCE-FORM" - :sb-debug))) - (cond ((fboundp print-code-sym) - `(,print-code-sym code-location context)) - ((fboundp code-sym) - `(prin1 (,code-sym code-location context))) - (t - (error - "*THWAP* SBCL changes its debugger interface ~ - again!")))))) - (printer-form))) (defun safe-source-location-for-emacs (code-location) (if *debug-definition-finding* From nsiivola at common-lisp.net Sat Jun 11 16:22:26 2005 From: nsiivola at common-lisp.net (Nikodemus Siivola) Date: Sat, 11 Jun 2005 18:22:26 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/doc/slime.texi Message-ID: <20050611162226.D7745884A9@common-lisp.net> Update of /project/slime/cvsroot/slime/doc In directory common-lisp.net:/tmp/cvs-serv11444/doc Modified Files: slime.texi Log Message: Changes for supporting recent SBCLs. Date: Sat Jun 11 18:22:25 2005 Author: nsiivola Index: slime/doc/slime.texi diff -u slime/doc/slime.texi:1.38 slime/doc/slime.texi:1.39 --- slime/doc/slime.texi:1.38 Tue Jun 7 12:06:50 2005 +++ slime/doc/slime.texi Sat Jun 11 18:22:24 2005 @@ -46,7 +46,7 @@ @end macro @set EDITION 1.2 - at set UPDATED @code{$Date: 2005/06/07 10:06:50 $} + at set UPDATED @code{$Date: 2005/06/11 16:22:24 $} @titlepage @title SLIME User Manual @@ -214,8 +214,7 @@ @item CMU Common Lisp (@acronym{CMUCL}), 18e or newer @item -Steel Bank Common Lisp (@acronym{SBCL}), from version 0.8.15 to 0.8.21 -(newer versions may or may not work) +Steel Bank Common Lisp (@acronym{SBCL}), latest official release @item OpenMCL, version 0.14.3 @item From crhodes at common-lisp.net Sun Jun 12 16:33:55 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sun, 12 Jun 2005 18:33:55 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el slime/swank.lisp Message-ID: <20050612163355.D504E88448@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1688 Modified Files: ChangeLog slime.el swank.lisp Log Message: Minor changes to ED-IN-EMACS / slime-ed. Now (push 'swank:ed-in-emacs sb-ext:*ed-functions*) works more-or-less as required. (We don't obey the constraint that file-error conditions be signalled on file system errors, but...) Date: Sun Jun 12 18:33:50 2005 Author: crhodes Index: slime/ChangeLog diff -u slime/ChangeLog:1.711 slime/ChangeLog:1.712 --- slime/ChangeLog:1.711 Sat Jun 11 18:22:23 2005 +++ slime/ChangeLog Sun Jun 12 18:33:49 2005 @@ -1,3 +1,12 @@ +2005-06-12 Christophe Rhodes + + * swank.lisp (ed-in-emacs): allow strings as well as pathnames; + don't call emacs for things that the emacs editor doesn't know how + to deal with. Return T if we called emacs and NIL if not. + + * slime.el (slime-ed): Change a listp to consp, so that NIL + arguments are correctly handled. + 2005-06-11 Nikodemus Siivola * swank-sbcl.lisp: Patched for SBCL HEAD: utilize the new Index: slime/slime.el diff -u slime/slime.el:1.507 slime/slime.el:1.508 --- slime/slime.el:1.507 Fri Jun 10 19:51:32 2005 +++ slime/slime.el Sun Jun 12 18:33:49 2005 @@ -5651,7 +5651,7 @@ (select-frame slime-ed-frame)) (cond ((stringp what) (find-file (slime-from-lisp-filename what))) - ((listp what) + ((consp what) (find-file (first (slime-from-lisp-filename what))) (goto-line (second what)) ;; Find the correct column, without going past the end of Index: slime/swank.lisp diff -u slime/swank.lisp:1.306 slime/swank.lisp:1.307 --- slime/swank.lisp:1.306 Fri Jun 10 19:54:22 2005 +++ slime/swank.lisp Sun Jun 12 18:33:50 2005 @@ -1881,17 +1881,23 @@ "Edit WHAT in Emacs. WHAT can be: - A filename (string), - A list (FILENAME LINE [COLUMN]), + A pathname or a string, + A list (PATHNAME-OR-STRING LINE [COLUMN]), A function name (symbol), - nil." - (let ((target - (cond ((and (listp what) (pathnamep (first what))) - (cons (canonicalize-filename (car what)) (cdr what))) - ((pathnamep what) - (canonicalize-filename what)) - (t what)))) - (send-oob-to-emacs `(:ed ,target)))) + NIL. + +Returns true if it actually called emacs, or NIL if not." + (flet ((pathname-or-string-p (thing) + (or (pathnamep thing) (typep thing 'string)))) + (let ((target + (cond ((and (listp what) (pathname-or-string-p (first what))) + (cons (canonicalize-filename (car what)) (cdr what))) + ((pathname-or-string-p what) + (canonicalize-filename what)) + ((symbolp what) what) + (t (return-from ed-in-emacs nil))))) + (send-oob-to-emacs `(:ed ,target)) + t))) (defslimefun value-for-editing (form) "Return a readable value of FORM for editing in Emacs. From crhodes at common-lisp.net Sun Jun 12 21:05:32 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sun, 12 Jun 2005 23:05:32 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/slime.el Message-ID: <20050612210532.ED446884A9@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18199 Modified Files: ChangeLog slime.el Log Message: >From Alexey Dejneka: fix "pgk" typo. Date: Sun Jun 12 23:05:29 2005 Author: crhodes Index: slime/ChangeLog diff -u slime/ChangeLog:1.712 slime/ChangeLog:1.713 --- slime/ChangeLog:1.712 Sun Jun 12 18:33:49 2005 +++ slime/ChangeLog Sun Jun 12 23:05:29 2005 @@ -1,3 +1,7 @@ +2005-06-12 Alexey Dejneka + + * slime.el (slime-with-xref-buffer): fix "pgk" typo. + 2005-06-12 Christophe Rhodes * swank.lisp (ed-in-emacs): allow strings as well as pathnames; Index: slime/slime.el diff -u slime/slime.el:1.508 slime/slime.el:1.509 --- slime/slime.el:1.508 Sun Jun 12 18:33:49 2005 +++ slime/slime.el Sun Jun 12 23:05:29 2005 @@ -6307,11 +6307,11 @@ (defmacro* slime-with-xref-buffer ((package ref-type symbol) &body body) "Execute BODY in a xref buffer, then show that buffer." (let ((type (gensym)) (sym (gensym)) (pkg (gensym))) - `(let ((,type ,ref-type) (,sym ,symbol) (,pgk ,package)) + `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package)) (with-current-buffer (get-buffer-create (format "*XREF[%s: %s]*" ,type ,sym)) (prog2 (progn - (slime-init-xref-buffer ,pgk ,type ,sym) + (slime-init-xref-buffer ,pkg ,type ,sym) (make-local-variable 'slime-xref-saved-window-configuration) (setq slime-xref-saved-window-configuration (current-window-configuration))) From eweitz at common-lisp.net Mon Jun 13 09:17:34 2005 From: eweitz at common-lisp.net (Edi Weitz) Date: Mon, 13 Jun 2005 11:17:34 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank-lispworks.lisp Message-ID: <20050613091734.2206E8816B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31867 Modified Files: ChangeLog swank-lispworks.lisp Log Message: Fix LW port (broken due to nregex renaming) Date: Mon Jun 13 11:17:33 2005 Author: eweitz Index: slime/ChangeLog diff -u slime/ChangeLog:1.713 slime/ChangeLog:1.714 --- slime/ChangeLog:1.713 Sun Jun 12 23:05:29 2005 +++ slime/ChangeLog Mon Jun 13 11:17:32 2005 @@ -1,3 +1,8 @@ +2005-06-13 Edi Weitz + + * swank-lispworks.lisp (unmangle-unfun): If you rename a package + you should rename it everywhere... + 2005-06-12 Alexey Dejneka * slime.el (slime-with-xref-buffer): fix "pgk" typo. Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.72 slime/swank-lispworks.lisp:1.73 --- slime/swank-lispworks.lisp:1.72 Thu May 5 10:59:13 2005 +++ slime/swank-lispworks.lisp Mon Jun 13 11:17:32 2005 @@ -533,18 +533,18 @@ function names like \(SETF GET)." (or (and (eq (symbol-package symbol) (load-time-value (find-package :setf))) - (let ((nregex::*regex-groupings* 0) - (nregex::*regex-groups* (make-array 10)) + (let ((slime-nregex::*regex-groupings* 0) + (slime-nregex::*regex-groups* (make-array 10)) (symbol-name (symbol-name symbol))) (and (funcall (load-time-value - (compile nil (nregex:regex-compile "^\"(.+)\" \"(.+)\"$"))) + (compile nil (slime-nregex:regex-compile "^\"(.+)\" \"(.+)\"$"))) symbol-name) (list 'setf (intern (apply #'subseq symbol-name - (aref nregex::*regex-groups* 2)) + (aref slime-nregex::*regex-groups* 2)) (find-package (apply #'subseq symbol-name - (aref nregex::*regex-groups* 1)))))))) + (aref slime-nregex::*regex-groups* 1)))))))) symbol)) (defun signal-undefined-functions (htab &optional filename) From eweitz at common-lisp.net Mon Jun 13 09:34:54 2005 From: eweitz at common-lisp.net (Edi Weitz) Date: Mon, 13 Jun 2005 11:34:54 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank.lisp Message-ID: <20050613093454.01BCE8816B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv900 Modified Files: ChangeLog swank.lisp Log Message: remove duplicate asdf systems Date: Mon Jun 13 11:34:54 2005 Author: eweitz Index: slime/ChangeLog diff -u slime/ChangeLog:1.714 slime/ChangeLog:1.715 --- slime/ChangeLog:1.714 Mon Jun 13 11:17:32 2005 +++ slime/ChangeLog Mon Jun 13 11:34:53 2005 @@ -1,5 +1,8 @@ 2005-06-13 Edi Weitz + * swank.lisp (list-all-systems-in-central-registry): Delete + duplicates. + * swank-lispworks.lisp (unmangle-unfun): If you rename a package you should rename it everywhere... Index: slime/swank.lisp diff -u slime/swank.lisp:1.307 slime/swank.lisp:1.308 --- slime/swank.lisp:1.307 Sun Jun 12 18:33:50 2005 +++ slime/swank.lisp Mon Jun 13 11:34:53 2005 @@ -2227,17 +2227,19 @@ (defslimefun list-all-systems-in-central-registry () "Returns a list of all systems in ASDF's central registry." - (loop for dir in (asdf-central-registry) - for defaults = (eval dir) - when defaults - nconc (mapcar #'file-namestring - (directory - (make-pathname :defaults defaults - :version :newest - :type "asd" - :name :wild - :case :local))))) - + (delete-duplicates + (loop for dir in (asdf-central-registry) + for defaults = (eval dir) + when defaults + nconc (mapcar #'file-namestring + (directory + (make-pathname :defaults defaults + :version :newest + :type "asd" + :name :wild + :case :local)))) + :test #'string=)) + (defun file-newer-p (new-file old-file) "Returns true if NEW-FILE is newer than OLD-FILE." (> (file-write-date new-file) (file-write-date old-file))) From eweitz at common-lisp.net Tue Jun 21 18:28:59 2005 From: eweitz at common-lisp.net (Edi Weitz) Date: Tue, 21 Jun 2005 20:28:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank.lisp Message-ID: <20050621182859.AFDEB88160@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23921 Modified Files: ChangeLog swank.lisp Log Message: Add package nicknames to completion results Date: Tue Jun 21 20:28:58 2005 Author: eweitz Index: slime/ChangeLog diff -u slime/ChangeLog:1.715 slime/ChangeLog:1.716 --- slime/ChangeLog:1.715 Mon Jun 13 11:34:53 2005 +++ slime/ChangeLog Tue Jun 21 20:28:58 2005 @@ -1,3 +1,7 @@ +2005-06-21 Edi Weitz + + * swank.lisp (find-matching-packages): Also use nicknames. + 2005-06-13 Edi Weitz * swank.lisp (list-all-systems-in-central-registry): Delete Index: slime/swank.lisp diff -u slime/swank.lisp:1.308 slime/swank.lisp:1.309 --- slime/swank.lisp:1.308 Mon Jun 13 11:34:53 2005 +++ slime/swank.lisp Tue Jun 21 20:28:58 2005 @@ -2383,7 +2383,9 @@ (remove-if-not (lambda (x) (funcall matcher to-match x)) (mapcar (lambda (pkgname) (concatenate 'string pkgname ":")) - (mapcar #'package-name (list-all-packages)))))) + (loop for package in (list-all-packages) + collect (package-name package) + append (package-nicknames package)))))) (defun parse-completion-arguments (string default-package-name) "Parse STRING as a symbol designator. From ewiborg at common-lisp.net Wed Jun 1 10:31:21 2005 From: ewiborg at common-lisp.net (Espon Wiborg) Date: Wed, 1 Jun 2005 12:31:21 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-loader.lisp slime/ChangeLog Message-ID: <20050601103121.568ED880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4285 Modified Files: swank-loader.lisp ChangeLog Log Message: Redefine compile-files-if-needed-serially for Corman Lisp to load everything from source. Date: Wed Jun 1 12:31:20 2005 Author: ewiborg Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.48 slime/swank-loader.lisp:1.49 --- slime/swank-loader.lisp:1.48 Tue May 31 20:38:41 2005 +++ slime/swank-loader.lisp Wed Jun 1 12:31:18 2005 @@ -125,6 +125,12 @@ (load source-pathname)) )))))) +#+cormanlisp +(defun compile-files-if-needed-serially (files) + "Corman Lisp has trouble with compiled files." + (dolist (file files) + (load file :verbose t))) + (compile-files-if-needed-serially (append (list (make-swank-pathname "swank-backend")) *sysdep-pathnames* Index: slime/ChangeLog diff -u slime/ChangeLog:1.700 slime/ChangeLog:1.701 --- slime/ChangeLog:1.700 Tue May 31 20:38:58 2005 +++ slime/ChangeLog Wed Jun 1 12:31:20 2005 @@ -1,3 +1,8 @@ +2005-06-01 Espen Wiborg + + * swank-loader.lisp: Redefine compile-files-if-needed-serially for + Corman Lisp to load everything from source. + 2005-05-27 Espen Wiborg * swank-corman.lisp: New file, swank for Corman Lisp. From heller at common-lisp.net Wed Jun 1 12:22:26 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:22:26 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050601122226.96234880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11330 Modified Files: slime.el Log Message: Distinguish macro and special operators from functions. Date: Wed Jun 1 14:22:25 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.500 slime/slime.el:1.501 --- slime/slime.el:1.500 Tue May 24 21:08:52 2005 +++ slime/slime.el Wed Jun 1 14:22:25 2005 @@ -6195,6 +6195,8 @@ in '((:variable "Variable") (:function "Function") (:generic-function "Generic Function") + (:macro "Macro") + (:special-operator "Special Operator") (:setf "Setf") (:type "Type") (:class "Class") @@ -6202,6 +6204,7 @@ (:alien-struct "Alien struct") (:alien-union "Alien type") (:alien-enum "Alien enum")) + ;; Properties not listed here will not show up in the buffer do (let ((value (plist-get plist prop)) (start (point))) From heller at common-lisp.net Wed Jun 1 12:22:29 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:22:29 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: <20050601122229.7BAAE880DE@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11352 Modified Files: swank-clisp.lisp Log Message: Distinguish macro and special operators from functions. Date: Wed Jun 1 14:22:28 2005 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.46 slime/swank-clisp.lisp:1.47 --- slime/swank-clisp.lisp:1.46 Sun Mar 27 20:40:51 2005 +++ slime/swank-clisp.lisp Wed Jun 1 14:22:28 2005 @@ -143,16 +143,23 @@ "Return a plist describing SYMBOL. Return NIL if the symbol is unbound." (let ((result ())) - (labels ((doc (kind) - (or (documentation symbol kind) :not-documented)) - (maybe-push (property value) - (when value - (setf result (list* property value result))))) - (when (fboundp symbol) - (if (macro-function symbol) - (setf (getf result :macro) (doc 'function)) - (setf (getf result :function) (doc 'function)))) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) (maybe-push :class (when (find-class symbol nil) (doc 'type))) ;this should be fixed result))) From heller at common-lisp.net Wed Jun 1 12:22:41 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:22:41 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: <20050601122241.1EA4B880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11379 Modified Files: swank-cmucl.lisp Log Message: Distinguish macro and special operators from functions. Date: Wed Jun 1 14:22:38 2005 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.147 slime/swank-cmucl.lisp:1.148 --- slime/swank-cmucl.lisp:1.147 Fri May 6 13:12:03 2005 +++ slime/swank-cmucl.lisp Wed Jun 1 14:22:37 2005 @@ -1176,15 +1176,13 @@ (declare (ignore kind)) (if (or (boundp symbol) recorded-p) (doc 'variable)))) - (maybe-push - :generic-function - (if (and (fboundp symbol) - (typep (fdefinition symbol) 'generic-function)) - (doc 'function))) - (maybe-push - :function (if (and (fboundp symbol) - (not (typep (fdefinition symbol) 'generic-function))) - (doc 'function))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) (maybe-push :setf (if (or (ext:info setf inverse symbol) (ext:info setf expander symbol)) @@ -2086,7 +2084,7 @@ (defun generation-stats () "Return a string describing the size distribution among the generations." (let* ((alloc (loop for i below gc-generations - collect (lisp::gencgc-stats i))) + collect (lisp::gencgc-stats i))) (sum (coerce (reduce #'+ alloc) 'float))) (format nil "~{~3F~^/~}" (mapcar (lambda (size) (/ size sum)) @@ -2095,9 +2093,9 @@ (defvar *gc-start-time* 0) (defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) (let ((msg (format nil "[Commencing GC with ~A in use.]" (print-bytes bytes-in-use)))) - (setq *gc-start-time* (get-internal-real-time)) (when (sending-safe-p) (eval-in-emacs `(slime-background-message "%s" ,msg) t)))) From heller at common-lisp.net Wed Jun 1 12:22:46 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:22:46 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: <20050601122246.BB24F880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11408 Modified Files: swank-sbcl.lisp Log Message: Distinguish macro and special operators from functions. Date: Wed Jun 1 14:22:46 2005 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.132 slime/swank-sbcl.lisp:1.133 --- slime/swank-sbcl.lisp:1.132 Wed Apr 20 14:43:49 2005 +++ slime/swank-sbcl.lisp Wed Jun 1 14:22:45 2005 @@ -594,20 +594,25 @@ "Return a plist describing SYMBOL. Return NIL if the symbol is unbound." (let ((result '())) - (labels ((doc (kind) - (or (documentation symbol kind) :not-documented)) - (maybe-push (property value) - (when value - (setf result (list* property value result))))) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) (maybe-push :variable (multiple-value-bind (kind recorded-p) (sb-int:info :variable :kind symbol) (declare (ignore kind)) (if (or (boundp symbol) recorded-p) (doc 'variable)))) - (maybe-push - :function (if (fboundp symbol) - (doc 'function))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) (maybe-push :setf (if (or (sb-int:info :setf :inverse symbol) (sb-int:info :setf :expander symbol)) @@ -1130,8 +1135,10 @@ (defimplementation quit-lisp () #+sb-thread (dolist (thread (remove (current-thread) (all-threads))) - (ignore-errors (sb-thread:terminate-thread thread))) + (ignore-errors (sb-thread:interrupt-thread + thread (lambda () (sb-ext:quit :recklessly-p t))))) (sb-ext:quit)) + ;;Trace implementations From heller at common-lisp.net Wed Jun 1 12:27:25 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:27:25 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050601122725.65C62880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11448 Modified Files: swank.lisp Log Message: (present-symbol-before-p): make it conform to its specification -- sort first by package and then by symbol name. Date: Wed Jun 1 14:27:24 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.303 slime/swank.lisp:1.304 --- slime/swank.lisp:1.303 Tue May 31 20:37:52 2005 +++ slime/swank.lisp Wed Jun 1 14:27:24 2005 @@ -2930,19 +2930,28 @@ (let ((y (funcall f x))) (and y (list y))))) -(defun present-symbol-before-p (a b) +(defun present-symbol-before-p (x y) "Return true if A belongs before B in a printed summary of symbols. Sorted alphabetically by package name and then symbol name, except that symbols accessible in the current package go first." + (declare (type symbol x y)) (flet ((accessible (s) - (find-symbol (symbol-name s) *buffer-package*))) - (cond ((and (accessible a) (accessible b)) - (string< (symbol-name a) (symbol-name b))) - ((accessible a) t) - ((accessible b) nil) - (t - (string< (package-name (symbol-package a)) - (package-name (symbol-package b))))))) + (or + (eq (symbol-package s) *buffer-package*) ; a short-cut + ;; Test breaks on NIL for package that does not inherit it + (eq (find-symbol (symbol-name s) *buffer-package*) s)))) + (let ((ax (accessible x)) (ay (accessible y))) + (if ax + (if ay + (string< (symbol-name x) (symbol-name y)) + t) + (if ay + nil + (let ((px (symbol-package x)) + (py (symbol-package y))) + (if (eq px py) + (string< (symbol-name x) (symbol-name y)) + (string< px py)))))))) (let ((regex-hash (make-hash-table :test #'equal))) (defun compiled-regex (regex-string) From heller at common-lisp.net Wed Jun 1 12:41:09 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:41:09 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050601124109.3936988772@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12391 Modified Files: swank.lisp Log Message: (present-symbol-before-p): Fix docstring; remove optimization; compare package names correctly. Date: Wed Jun 1 14:41:07 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.304 slime/swank.lisp:1.305 --- slime/swank.lisp:1.304 Wed Jun 1 14:27:24 2005 +++ slime/swank.lisp Wed Jun 1 14:41:02 2005 @@ -2931,27 +2931,21 @@ (and y (list y))))) (defun present-symbol-before-p (x y) - "Return true if A belongs before B in a printed summary of symbols. + "Return true if X belongs before Y in a printed summary of symbols. Sorted alphabetically by package name and then symbol name, except that symbols accessible in the current package go first." (declare (type symbol x y)) (flet ((accessible (s) - (or - (eq (symbol-package s) *buffer-package*) ; a short-cut - ;; Test breaks on NIL for package that does not inherit it - (eq (find-symbol (symbol-name s) *buffer-package*) s)))) + ;; Test breaks on NIL for package that does not inherit it + (eq (find-symbol (symbol-name s) *buffer-package*) s))) (let ((ax (accessible x)) (ay (accessible y))) - (if ax - (if ay - (string< (symbol-name x) (symbol-name y)) - t) - (if ay - nil - (let ((px (symbol-package x)) - (py (symbol-package y))) - (if (eq px py) - (string< (symbol-name x) (symbol-name y)) - (string< px py)))))))) + (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) + (ax t) + (ay nil) + (t (let ((px (symbol-package x)) (py (symbol-package y))) + (if (eq px py) + (string< (symbol-name x) (symbol-name y)) + (string< (package-name px) (package-name py))))))))) (let ((regex-hash (make-hash-table :test #'equal))) (defun compiled-regex (regex-string) From heller at common-lisp.net Wed Jun 1 12:50:05 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:50:05 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: <20050601125005.0FE8F880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13283 Modified Files: swank-clisp.lisp Log Message: (describe-symbol-for-emacs): Report :alien-type when the name is known as foreign type. Date: Wed Jun 1 14:50:05 2005 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.47 slime/swank-clisp.lisp:1.48 --- slime/swank-clisp.lisp:1.47 Wed Jun 1 14:22:28 2005 +++ slime/swank-clisp.lisp Wed Jun 1 14:50:05 2005 @@ -162,6 +162,18 @@ (doc 'function))) (maybe-push :class (when (find-class symbol nil) (doc 'type))) ;this should be fixed + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) result))) (defimplementation describe-definition (symbol namespace) From heller at common-lisp.net Wed Jun 1 12:53:26 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 14:53:26 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050601125326.B9C45880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13369 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jun 1 14:53:26 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.701 slime/ChangeLog:1.702 --- slime/ChangeLog:1.701 Wed Jun 1 12:31:20 2005 +++ slime/ChangeLog Wed Jun 1 14:53:25 2005 @@ -1,3 +1,18 @@ +2005-06-01 Joerg Hoehle + + * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp.lisp + (describe-symbol-for-emacs): Distinguish macro and special + operators from functions. + + * slime.el (slime-print-apropos): Must keep in sync with above, + therefore added :macro and :special-operator properties. + + * swank.lisp (present-symbol-before-p): Make it conform to its + specification -- sort first by package and then by symbol name. + + * swank-clisp.lisp (describe-symbol-for-emacs): Report :alien-type + when the name is known as foreign type. + 2005-06-01 Espen Wiborg * swank-loader.lisp: Redefine compile-files-if-needed-serially for From heller at common-lisp.net Wed Jun 1 13:48:39 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 15:48:39 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050601134839.74B9D880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17169 Modified Files: slime.el Log Message: (slime-first-change-hook): Don't do anything if slime-mode is disabled. Date: Wed Jun 1 15:48:38 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.501 slime/slime.el:1.502 --- slime/slime.el:1.501 Wed Jun 1 14:22:25 2005 +++ slime/slime.el Wed Jun 1 15:48:38 2005 @@ -5586,7 +5586,8 @@ ;; breaks. -luke (26/Jul/2004) (save-excursion (save-match-data - (when (and (buffer-file-name) + (when (and slime-mode + (buffer-file-name) (slime-connected-p)) (let ((filename (slime-to-lisp-filename (buffer-file-name)))) (slime-eval-async `(swank:buffer-first-change ,filename))))))) From heller at common-lisp.net Wed Jun 1 13:49:11 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 15:49:11 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050601134911.A1806880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17198 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jun 1 15:49:10 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.702 slime/ChangeLog:1.703 --- slime/ChangeLog:1.702 Wed Jun 1 14:53:25 2005 +++ slime/ChangeLog Wed Jun 1 15:49:10 2005 @@ -1,3 +1,8 @@ +2005-06-01 Helmut Eller + + * slime.el (slime-first-change-hook): Don't do anything if + slime-mode is disabled. + 2005-06-01 Joerg Hoehle * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp.lisp From heller at common-lisp.net Wed Jun 1 14:28:27 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 16:28:27 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050601142827.AC53A880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19117 Modified Files: slime.el Log Message: (slime-background-activities-enabled-p): Return nil instead of signalling an error if there is a open but no default connection. (slime-current-connection): New helper function. (slime-connection): Use it. Date: Wed Jun 1 16:28:26 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.502 slime/slime.el:1.503 --- slime/slime.el:1.502 Wed Jun 1 15:48:38 2005 +++ slime/slime.el Wed Jun 1 16:28:26 2005 @@ -1776,11 +1776,17 @@ Used for all Lisp communication, except when overridden by `slime-dispatching-connection' or `slime-buffer-connection'.") +(defun slime-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or slime-dispatching-connection + slime-buffer-connection + slime-default-connection)) + (defun slime-connection () - "Return the connection to use for Lisp interaction." - (let ((conn (or slime-dispatching-connection - slime-buffer-connection - slime-default-connection))) + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (slime-current-connection))) (cond ((and (not conn) slime-net-processes) (error "No default connection selected.")) ((not conn) @@ -2033,7 +2039,8 @@ "*If true, don't send background requests if Lisp is already busy.") (defun slime-background-activities-enabled-p () - (and (slime-connected-p) + (and slime-mode + (slime-current-connection) (or (not (slime-busy-p)) (not slime-inhibit-pipelining)))) From heller at common-lisp.net Wed Jun 1 14:38:51 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 16:38:51 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050601143851.B6943880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20252 Modified Files: slime.el Log Message: (slime-first-change-hook): Use slime-background-activities-enabled-p. Date: Wed Jun 1 16:38:50 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.503 slime/slime.el:1.504 --- slime/slime.el:1.503 Wed Jun 1 16:28:26 2005 +++ slime/slime.el Wed Jun 1 16:38:50 2005 @@ -5593,9 +5593,8 @@ ;; breaks. -luke (26/Jul/2004) (save-excursion (save-match-data - (when (and slime-mode - (buffer-file-name) - (slime-connected-p)) + (when (and (buffer-file-name) + (slime-background-activities-enabled-p)) (let ((filename (slime-to-lisp-filename (buffer-file-name)))) (slime-eval-async `(swank:buffer-first-change ,filename))))))) From heller at common-lisp.net Wed Jun 1 14:40:43 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 16:40:43 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050601144043.35E3C880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20292 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jun 1 16:40:42 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.703 slime/ChangeLog:1.704 --- slime/ChangeLog:1.703 Wed Jun 1 15:49:10 2005 +++ slime/ChangeLog Wed Jun 1 16:40:42 2005 @@ -1,7 +1,12 @@ 2005-06-01 Helmut Eller - * slime.el (slime-first-change-hook): Don't do anything if - slime-mode is disabled. + * slime.el (slime-background-activities-enabled-p): Return nil + instead of signalling an error if there is a open but no default + connection. + (slime-current-connection): New helper function. + (slime-connection): Use it. + (slime-first-change-hook): Only run when + slime-background-activities-enabled-p. 2005-06-01 Joerg Hoehle From heller at common-lisp.net Wed Jun 1 15:02:49 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 17:02:49 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: <20050601150249.676D8880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22026 Modified Files: swank-clisp.lisp Log Message: (getpid): Use defimplementation. Define always (slime needs it). Date: Wed Jun 1 17:02:48 2005 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.48 slime/swank-clisp.lisp:1.49 --- slime/swank-clisp.lisp:1.48 Wed Jun 1 14:50:05 2005 +++ slime/swank-clisp.lisp Wed Jun 1 17:02:48 2005 @@ -32,8 +32,8 @@ (when (find-package "LINUX") (pushnew :linux *features*))) -;;;; if this listp has the complete CLOS then we use it, othewise we -;;;; build up a "fake" swank-mop and then overide the methods in the +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" swank-mop and then override the methods in the ;;;; inspector. (eval-when (:compile-toplevel :load-toplevel :execute) @@ -42,7 +42,7 @@ (eql :external (nth-value 1 (find-symbol (string ':standard-slot-definition) :clos)))) - "True in those CLISP imagse which have a complete MOP implementation.")) + "True in those CLISP images which have a complete MOP implementation.")) #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or)) (progn @@ -80,20 +80,17 @@ (defimplementation call-without-interrupts (fn) (funcall fn)) -#+unix -(defmethod getpid () - (funcall (or (find-symbol "PROGRAM-ID" :system) - (find-symbol "PROCESS-ID" :system) - (error "getpid not implemented")))) - -#+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! +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) (defimplementation lisp-implementation-type-name () "clisp") From heller at common-lisp.net Wed Jun 1 15:03:53 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 17:03:53 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050601150353.510CB880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22063 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jun 1 17:03:53 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.704 slime/ChangeLog:1.705 --- slime/ChangeLog:1.704 Wed Jun 1 16:40:42 2005 +++ slime/ChangeLog Wed Jun 1 17:03:52 2005 @@ -1,3 +1,8 @@ +2005-06-01 Joerg Hoehle + + * swank-clisp (getpid): Updates for current CLISP versions. Use + defimplementation. Define always (slime needs it). + 2005-06-01 Helmut Eller * slime.el (slime-background-activities-enabled-p): Return nil From heller at common-lisp.net Wed Jun 1 16:59:55 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 18:59:55 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050601165955.B3CE8880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28809 Modified Files: slime.el Log Message: *** empty log message *** Date: Wed Jun 1 18:59:55 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.504 slime/slime.el:1.505 --- slime/slime.el:1.504 Wed Jun 1 16:38:50 2005 +++ slime/slime.el Wed Jun 1 18:59:54 2005 @@ -870,7 +870,8 @@ "Setup a buffer-local `pre-command-h'ook' to call `slime-pre-command-hook'." (make-local-hook 'pre-command-hook) (make-local-hook 'post-command-hook) - (add-hook 'pre-command-hook 'slime-pre-command-hook nil t) ; alanr: need local t + ;; alanr: need local t + (add-hook 'pre-command-hook 'slime-pre-command-hook nil t) (add-hook 'post-command-hook 'slime-post-command-hook nil t)) ;(add-hook 'slime-mode-hook 'slime-setup-command-hooks) @@ -3763,13 +3764,13 @@ (and asdf-systems-in-directory (file-name-sans-extension (car asdf-systems-in-directory))))) -(defun slime-load-system (&optional system-name) +(defun slime-load-system (&optional system) "Compile and load an ASDF system. Default system name is taken from first file matching *.asd in current buffer's working directory" (interactive (list (slime-read-system-name))) - (slime-oos system-name "LOAD-OP")) + (slime-oos system "LOAD-OP")) (defun slime-read-system-name (&optional prompt initial-value) "Read a system name from the minibuffer, prompting with PROMPT." @@ -3782,14 +3783,14 @@ (completing-read prompt alist nil nil (or initial-value (slime-find-asd) "")))) -(defun slime-oos (system-name operation &rest keyword-args) +(defun slime-oos (system operation &rest keyword-args) (save-some-buffers) (slime-display-output-buffer) (message "Performing ASDF %S%s on system %S" operation (if keyword-args (format " %S" keyword-args) "") - system-name) + system) (slime-eval-async - `(swank:operate-on-system-for-emacs ,system-name ,operation , at keyword-args) + `(swank:operate-on-system-for-emacs ,system ,operation , at keyword-args) (slime-compilation-finished-continuation))) (defun slime-compile-defun () From heller at common-lisp.net Wed Jun 1 17:00:14 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 1 Jun 2005 19:00:14 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050601170014.031CD880DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29041 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jun 1 19:00:13 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.705 slime/ChangeLog:1.706 --- slime/ChangeLog:1.705 Wed Jun 1 17:03:52 2005 +++ slime/ChangeLog Wed Jun 1 19:00:13 2005 @@ -1,3 +1,10 @@ +2005-06-01 Helmut Eller + + * slime.el (slime-load-system, slime-oos): Fix bug related to file + locking. Don't bind the variable system-name. system-name is a + predefined Emacs variable and is used among other things for lock + filenames. + 2005-06-01 Joerg Hoehle * swank-clisp (getpid): Updates for current CLISP versions. Use From heller at common-lisp.net Fri Jun 3 11:16:46 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 3 Jun 2005 13:16:46 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: <20050603111646.214F58875E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21805 Modified Files: swank-cmucl.lisp Log Message: *** empty log message *** Date: Fri Jun 3 13:16:45 2005 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.148 slime/swank-cmucl.lisp:1.149 --- slime/swank-cmucl.lisp:1.148 Wed Jun 1 14:22:37 2005 +++ slime/swank-cmucl.lisp Fri Jun 3 13:16:45 2005 @@ -271,7 +271,8 @@ (:line-length nil) (:get-command nil) (:element-type 'base-char) - (:close nil))) + (:close nil) + (:interactive-p t))) ;;;; Compilation Commands From heller at common-lisp.net Fri Jun 3 11:17:38 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 3 Jun 2005 13:17:38 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050603111738.508C78875E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21846 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jun 3 13:17:37 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.706 slime/ChangeLog:1.707 --- slime/ChangeLog:1.706 Wed Jun 1 19:00:13 2005 +++ slime/ChangeLog Fri Jun 3 13:17:37 2005 @@ -1,3 +1,7 @@ +2005-06-03 Helmut Eller + + * swank-cmucl.lisp (sis/misc): Return t for :interactive-p. + 2005-06-01 Helmut Eller * slime.el (slime-load-system, slime-oos): Fix bug related to file From heller at common-lisp.net Fri Jun 3 20:00:13 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 3 Jun 2005 22:00:13 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050603200013.55E388875E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20291 Modified Files: slime.el Log Message: (slime-background-activities-enabled-p): Allow background stuff in repl-mode buffers too. Date: Fri Jun 3 22:00:12 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.505 slime/slime.el:1.506 --- slime/slime.el:1.505 Wed Jun 1 18:59:54 2005 +++ slime/slime.el Fri Jun 3 22:00:11 2005 @@ -366,7 +366,11 @@ "Face for the prompt in the SLIME REPL." :group 'slime-repl) -(defcustom slime-repl-enable-presentations t; (not (featurep 'xemacs)) - alanr should work now. +(defcustom slime-repl-enable-presentations + (cond ((and (not (featurep 'xemacs)) (= emacs-major-version 20)) + ;; mouseable text sucks in Emacs 20 + nil) + (t t)) "Should we enable presentations" :type '(boolean) :group 'slime-repl) @@ -2040,7 +2044,8 @@ "*If true, don't send background requests if Lisp is already busy.") (defun slime-background-activities-enabled-p () - (and slime-mode + (and (or slime-mode + (eq major-mode 'slime-repl-mode)) (slime-current-connection) (or (not (slime-busy-p)) (not slime-inhibit-pipelining)))) From heller at common-lisp.net Fri Jun 3 20:00:29 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 3 Jun 2005 22:00:29 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050603200029.2B43B8875E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20513 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jun 3 22:00:28 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.707 slime/ChangeLog:1.708 --- slime/ChangeLog:1.707 Fri Jun 3 13:17:37 2005 +++ slime/ChangeLog Fri Jun 3 22:00:28 2005 @@ -1,5 +1,8 @@ 2005-06-03 Helmut Eller + * slime.el (slime-background-activities-enabled-p): Allow + background stuff in repl-mode buffers too. + * swank-cmucl.lisp (sis/misc): Return t for :interactive-p. 2005-06-01 Helmut Eller From ewiborg at common-lisp.net Tue Jun 7 10:06:52 2005 From: ewiborg at common-lisp.net (Espen Wiborg) Date: Tue, 7 Jun 2005 12:06:52 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/PROBLEMS Message-ID: <20050607100652.39974880DD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10887 Modified Files: PROBLEMS Log Message: Added notes about CCL. Date: Tue Jun 7 12:06:51 2005 Author: ewiborg Index: slime/PROBLEMS diff -u slime/PROBLEMS:1.5 slime/PROBLEMS:1.6 --- slime/PROBLEMS:1.5 Tue Apr 19 22:23:57 2005 +++ slime/PROBLEMS Tue Jun 7 12:06:51 2005 @@ -70,3 +70,14 @@ The ABCL support is still new and experimental. +** Corman Common Lisp + +We require version 2.51 or higher, with several patches (available at +http://www.grumblesmurf.org/lisp/corman-patches). + +The only communication style currently supported is NIL. + +Interrupting (with C-c C-b) doesn't work. + +The tracing, stepping and XREF commands are not implemented along with +some debugger functionality. From ewiborg at common-lisp.net Tue Jun 7 10:06:51 2005 From: ewiborg at common-lisp.net (Espen Wiborg) Date: Tue, 7 Jun 2005 12:06:51 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/doc/slime.texi Message-ID: <20050607100651.B0A9A88031@common-lisp.net> Update of /project/slime/cvsroot/slime/doc In directory common-lisp.net:/tmp/cvs-serv10887/doc Modified Files: slime.texi Log Message: Added notes about CCL. Date: Tue Jun 7 12:06:50 2005 Author: ewiborg Index: slime/doc/slime.texi diff -u slime/doc/slime.texi:1.37 slime/doc/slime.texi:1.38 --- slime/doc/slime.texi:1.37 Mon Apr 18 20:58:12 2005 +++ slime/doc/slime.texi Tue Jun 7 12:06:50 2005 @@ -46,7 +46,7 @@ @end macro @set EDITION 1.2 - at set UPDATED @code{$Date: 2005/04/18 18:58:12 $} + at set UPDATED @code{$Date: 2005/06/07 10:06:50 $} @titlepage @title SLIME User Manual @@ -226,6 +226,8 @@ @acronym{CLISP}, version 2.33.2 or newer @item Armed Bear Common Lisp (@acronym{ABCL}) + at item +Corman Common Lisp (@acronym{CCL}), version 2.51 or newer with the patches from @url{http://www.grumblesmurf.org/lisp/corman-patches}) @end itemize Most features work uniformly across implementations, but some are @@ -1301,8 +1303,7 @@ @item slime-connected-hook This hook is run when @SLIME{} establishes a connection to a Lisp -server. An example use is to create a Typeout frame (@xref{Typeout -frames}.) +server. An example use is to create a Typeout frame (@xref{Typeout frames}.) @item sldb-hook This hook is run after @SLDB{} is invoked. The hook functions are From ewiborg at common-lisp.net Tue Jun 7 10:08:06 2005 From: ewiborg at common-lisp.net (Espen Wiborg) Date: Tue, 7 Jun 2005 12:08:06 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-corman.lisp slime/ChangeLog Message-ID: <20050607100806.9A80B88031@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10937 Modified Files: swank-corman.lisp ChangeLog Log Message: Convert to Unix line-endings. (create-socket): Pass through the port argument unmodified, gettting a random port if 0. Requires supporting change in /modules/sockets.lisp. (inspect-for-emacs): defimplementation instead of defmethod. Date: Tue Jun 7 12:08:05 2005 Author: ewiborg Index: slime/swank-corman.lisp diff -u slime/swank-corman.lisp:1.1 slime/swank-corman.lisp:1.2 --- slime/swank-corman.lisp:1.1 Tue May 31 20:36:52 2005 +++ slime/swank-corman.lisp Tue Jun 7 12:08:03 2005 @@ -1,477 +1,479 @@ -;;; -;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. -;;; -;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw at grumblesmurf.org) -;;; -;;; License -;;; ======= -;;; This software is provided 'as-is', without any express or implied -;;; warranty. In no event will the author be held liable for any damages -;;; arising from the use of this software. -;;; -;;; Permission is granted to anyone to use this software for any purpose, -;;; including commercial applications, and to alter it and redistribute -;;; it freely, subject to the following restrictions: -;;; -;;; 1. The origin of this software must not be misrepresented; you must -;;; not claim that you wrote the original software. If you use this -;;; software in a product, an acknowledgment in the product documentation -;;; would be appreciated but is not required. -;;; -;;; 2. Altered source versions must be plainly marked as such, and must -;;; not be misrepresented as being the original software. -;;; -;;; 3. This notice may not be removed or altered from any source -;;; distribution. -;;; -;;; Notes -;;; ===== -;;; You will need CCL 2.51, and you will *definitely* need to patch -;;; CCL with the patches at -;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME -;;; will blow up in your face. You should also follow the -;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. -;;; -;;; The only communication style currently supported is NIL. -;;; -;;; Starting CCL inside emacs (with M-x slime) seems to work for me -;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 -;;; (sometimes it works, other times it hangs on start or hangs when -;;; initializing WinSock) - starting CCL externally and using M-x -;;; slime-connect always works fine. -;;; -;;; Sometimes CCL gets confused and starts giving you random memory access violation errors on startup; if this happens, -;;; -;;; What works -;;; ========== -;;; * Basic editing and evaluation -;;; * Arglist display -;;; * Compilation -;;; * Loading files -;;; * apropos/describe -;;; * Debugger -;;; * Inspector -;;; -;;; TODO -;;; ==== -;;; * More debugger functionality (missing bits: restart-frame, -;;; return-from-frame, disassemble-frame, activate-stepping, -;;; toggle-trace) -;;; * XREF -;;; * Profiling -;;; * More sophisticated communication styles than NIL -;;; - -(in-package :swank-backend) - -;;; Pull in various needed bits -(require :composite-streams) -(require :sockets) -(require :winbase) -(require :lp) - -(use-package :gs) - -;; MOP stuff - -(defclass swank-mop:standard-slot-definition () - () - (:documentation "Dummy class created so that swank.lisp will compile and load.")) - -(defun named-by-gensym-p (c) - (null (symbol-package (class-name c)))) - -(deftype swank-mop:eql-specializer () - '(satisfies named-by-gensym-p)) - -(defun swank-mop:eql-specializer-object (specializer) - (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) - (loop (multiple-value-bind (more key value) - (next-entry) - (unless more (return nil)) - (when (eq specializer value) - (return key)))))) - -(defun swank-mop:class-finalized-p (class) - (declare (ignore class)) - t) - -(defun swank-mop:class-prototype (class) - (make-instance class)) - -(defun swank-mop:specializer-direct-methods (obj) - (declare (ignore obj)) - nil) - -(defun swank-mop:generic-function-argument-precedence-order (gf) - (generic-function-lambda-list gf)) - -(defun swank-mop:generic-function-method-combination (gf) - (declare (ignore gf)) - :standard) - -(defun swank-mop:generic-function-declarations (gf) - (declare (ignore gf)) - nil) - -(defun swank-mop:slot-definition-documentation (slot) - (declare (ignore slot)) - (getf slot :documentation nil)) - -(defun swank-mop:slot-definition-type (slot) - (declare (ignore slot)) - t) - -(import-swank-mop-symbols :cl '(;; classes - :standard-slot-definition - :eql-specializer - :eql-specializer-object - ;; standard class readers - :class-default-initargs - :class-direct-default-initargs - :class-finalized-p - :class-prototype - :specializer-direct-methods - ;; gf readers - :generic-function-argument-precedence-order - :generic-function-declarations - :generic-function-method-combination - ;; method readers - ;; slot readers - :slot-definition-documentation - :slot-definition-type)) - -;;;; swank implementations - -;;; Debugger - -(defvar *stack-trace* nil) -(defvar *frame-trace* nil) - -(defstruct frame - name function address debug-info variables) - -(defimplementation call-with-debugging-environment (fn) - (let* ((real-stack-trace (cl::stack-trace)) - (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace - :key #'car))) - (*frame-trace* - (let* ((db::*debug-level* 1) - (db::*debug-frame-pointer* (db::stash-ebp - (ct:create-foreign-ptr))) - (db::*debug-max-level* (length real-stack-trace)) - (db::*debug-min-level* 1)) - (cdr (member #'cl:invoke-debugger - (cons - (make-frame :function nil) - (loop for i from db::*debug-min-level* - upto db::*debug-max-level* - until (eq (db::get-frame-function i) cl::*top-level*) - collect - (make-frame :function (db::get-frame-function i) - :address (db::get-frame-address i)))) - :key #'frame-function))))) - (funcall fn))) - -(defimplementation compute-backtrace (start end) - (subseq *stack-trace* start (min end (length *stack-trace*)))) - -(defimplementation print-frame (frame stream) - (format stream "~S" frame)) - -(defun get-frame-debug-info (frame) - (let ((info (frame-debug-info frame))) - (if info - info - (setf (frame-debug-info frame) - (db::prepare-frame-debug-info (frame-function frame) - (frame-address frame)))))) - -(defimplementation frame-locals (frame-number) - (let* ((frame (elt *frame-trace* frame-number)) - (info (get-frame-debug-info frame))) - (let ((var-list - (loop for i from 4 below (length info) by 2 - collect `(list :name ',(svref info i) :id 0 - :value (db::debug-filter ,(svref info i)))))) - (let ((vars (eval-in-frame `(list , at var-list) frame-number))) - (setf (frame-variables frame) vars))))) - -(defimplementation eval-in-frame (form frame-number) - (let ((frame (elt *frame-trace* frame-number))) - (let ((cl::*compiler-environment* (get-frame-debug-info frame))) - (eval form)))) - -(defimplementation frame-catch-tags (index) - (declare (ignore index)) - nil) - -(defimplementation frame-var-value (frame-number var) - (let ((vars (frame-variables (elt *frame-trace* frame-number)))) - (when vars - (second (elt vars var))))) - -(defimplementation frame-source-location-for-emacs (frame-number) - (fspec-location (frame-function (elt *frame-trace* frame-number)))) - -;;; Socket communication - -(defimplementation create-socket (host port) - (sockets:start-sockets) - (sockets:make-server-socket :host host :port (if (zerop port) 4005 port))) - -(defimplementation local-port (socket) - (sockets:socket-port socket)) - -(defimplementation close-socket (socket) - (close socket)) - -(defimplementation accept-connection (socket - &key (external-format :iso-latin-1-unix)) - (ecase external-format - (:iso-latin-1-unix - (sockets:make-socket-stream (sockets:accept-socket socket))))) - -;;; Misc - -(defimplementation preferred-communication-style () - nil) - -(defimplementation getpid () - ccl:*current-process-id*) - -(defimplementation lisp-implementation-type-name () - "cormanlisp") - -(defimplementation quit-lisp () - (sockets:stop-sockets) - (win32:exitprocess 0)) - -(defimplementation set-default-directory (directory) - (setf (ccl:current-directory) directory) - (directory-namestring (setf *default-pathname-defaults* - (truename (merge-pathnames directory))))) - -(defimplementation default-directory () - (ccl:current-directory)) - -(defimplementation macroexpand-all (form) - (ccl:macroexpand-all form)) - -;;; Documentation - -(defun fspec-location (fspec) - (when (symbolp fspec) - (setq fspec (symbol-function fspec))) - (let ((file (ccl::function-source-file fspec))) - (if file - (handler-case - (let ((truename (truename - (merge-pathnames file - ccl:*cormanlisp-directory*)))) - (make-location (list :file (namestring truename)) - (if (ccl::function-source-line fspec) - (list :line (ccl::function-source-line fspec)) - (list :function-name (princ-to-string - (function-name fspec)))))) - (error (c) (list :error (princ-to-string c)))) - (list :error (format nil "No source information available for ~S" - fspec))))) - -(defimplementation find-definitions (name) - (list (list name (fspec-location name)))) - -(defimplementation arglist (name) - (handler-case - (cond ((and (symbolp name) - (macro-function name)) - (ccl::macro-lambda-list (symbol-function name))) - (t - (when (symbolp name) - (setq name (symbol-function name))) - (if (eq (class-of name) cl::the-class-standard-gf) - (generic-function-lambda-list name) - (ccl:function-lambda-list name)))) - (error () :not-available))) - -(defimplementation function-name (fn) - (handler-case (getf (cl::function-info-list fn) 'cl::function-name) - (error () nil))) - -(defimplementation describe-symbol-for-emacs (symbol) - (let ((result '())) - (flet ((doc (kind &optional (sym symbol)) - (or (documentation sym kind) :not-documented)) - (maybe-push (property value) - (when value - (setf result (list* property value result))))) - (maybe-push - :variable (when (boundp symbol) - (doc 'variable))) - (maybe-push - :function (if (fboundp symbol) - (doc 'function))) - (maybe-push - :class (if (find-class symbol nil) - (doc 'class))) - result))) - -(defimplementation describe-definition (symbol namespace) - (ecase namespace - (:variable - (describe symbol)) - ((:function :generic-function) - (describe (symbol-function symbol))) - (:class - (describe (find-class symbol))))) - -;;; Compiler - -(defvar *buffer-name* nil) -(defvar *buffer-position*) -(defvar *buffer-string*) -(defvar *compile-filename* nil) - -;; FIXME -(defimplementation call-with-compilation-hooks (FN) - (handler-bind ((error (lambda (c) - (signal (make-condition - 'compiler-condition - :original-condition c - :severity :warning - :message (format nil "~A" c) - :location - (cond (*buffer-name* - (make-location - (list :buffer *buffer-name*) - (list :position *buffer-position*))) - (*compile-filename* - (make-location - (list :file *compile-filename*) - (list :position 1))) - (t - (list :error "No location")))))))) - (funcall fn))) - -(defimplementation swank-compile-file (*compile-filename* load-p) - (with-compilation-hooks () - (let ((*buffer-name* nil)) - (compile-file *compile-filename*) - (when load-p - (load (compile-file-pathname *compile-filename*)))))) - -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) - (with-compilation-hooks () - (let ((*buffer-name* buffer) - (*buffer-position* position) - (*buffer-string* string)) - (funcall (compile nil (read-from-string - (format nil "(~S () ~A)" 'lambda string))))))) - -;;;; Inspecting - -(defclass corman-inspector (inspector) - ()) - -(defimplementation make-default-inspector () - (make-instance 'corman-inspector)) - -(defun comma-separated (list &optional (callback (lambda (v) - `(:value ,v)))) - (butlast (loop for e in list - collect (funcall callback e) - collect ", "))) - -(defmethod inspect-for-emacs ((class standard-class) - (inspector corman-inspector)) - (declare (ignore inspector)) - (values "A class." - `("Name: " (:value ,(class-name class)) - (:newline) - "Super classes: " - ,@(comma-separated (swank-mop:class-direct-superclasses class)) - (:newline) - "Direct Slots: " - ,@(comma-separated - (swank-mop:class-direct-slots class) - (lambda (slot) - `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot))))) - (:newline) - "Effective Slots: " - ,@(if (swank-mop:class-finalized-p class) - (comma-separated - (swank-mop:class-slots class) - (lambda (slot) - `(:value ,slot ,(princ-to-string - (swank-mop:slot-definition-name slot))))) - '("#")) - (:newline) - ,@(when (documentation class t) - `("Documentation:" (:newline) ,(documentation class t) (:newline))) - "Sub classes: " - ,@(comma-separated (swank-mop:class-direct-subclasses class) - (lambda (sub) - `(:value ,sub ,(princ-to-string (class-name sub))))) - (:newline) - "Precedence List: " - ,@(if (swank-mop:class-finalized-p class) - (comma-separated (swank-mop:class-precedence-list class) - (lambda (class) - `(:value ,class ,(princ-to-string (class-name class))))) - '("#")) - (:newline)))) - -(defmethod inspect-for-emacs ((slot cons) (inspector corman-inspector)) - ;; Inspects slot definitions - (declare (ignore corman-inspector)) - (if (eq (car slot) :name) - (values "A slot." - `("Name: " (:value ,(swank-mop:slot-definition-name slot)) - (:newline) - ,@(when (swank-mop:slot-definition-documentation slot) - `("Documentation:" (:newline) - (:value ,(swank-mop:slot-definition-documentation slot)) - (:newline))) - "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) - "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) - `(:value ,(swank-mop:slot-definition-initform slot)) - "#") (:newline) - "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) - (:newline))) - (call-next-method))) - -(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal) - inspector) - (declare (ignore inspector)) - (values (if (wild-pathname-p pathname) - "A wild pathname." - "A pathname.") - (append (label-value-line* - ("Namestring" (namestring pathname)) - ("Host" (pathname-host pathname)) - ("Device" (pathname-device pathname)) - ("Directory" (pathname-directory pathname)) - ("Name" (pathname-name pathname)) - ("Type" (pathname-type pathname)) - ("Version" (pathname-version pathname))) - (unless (or (wild-pathname-p pathname) - (not (probe-file pathname))) - (label-value-line "Truename" (truename pathname)))))) - -;;; This is probably not good, but it WFM -(in-package :common-lisp) - -(defvar *old-documentation* #'documentation) -(defun documentation (thing &optional (type 'function)) - (if (symbolp thing) - (funcall *old-documentation* thing type) - (values))) - -(defmethod print-object ((restart restart) stream) - (if (or *print-escape* - *print-readably*) - (print-unreadable-object (restart stream :type t :identity t) - (princ (restart-name restart) stream)) - (when (functionp (restart-report-function restart)) - (funcall (restart-report-function restart) stream)))) +;;; +;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. +;;; +;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw at grumblesmurf.org) +;;; +;;; License +;;; ======= +;;; This software is provided 'as-is', without any express or implied +;;; warranty. In no event will the author be held liable for any damages +;;; arising from the use of this software. +;;; +;;; Permission is granted to anyone to use this software for any purpose, +;;; including commercial applications, and to alter it and redistribute +;;; it freely, subject to the following restrictions: +;;; +;;; 1. The origin of this software must not be misrepresented; you must +;;; not claim that you wrote the original software. If you use this +;;; software in a product, an acknowledgment in the product documentation +;;; would be appreciated but is not required. +;;; +;;; 2. Altered source versions must be plainly marked as such, and must +;;; not be misrepresented as being the original software. +;;; +;;; 3. This notice may not be removed or altered from any source +;;; distribution. +;;; +;;; Notes +;;; ===== +;;; You will need CCL 2.51, and you will *definitely* need to patch +;;; CCL with the patches at +;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME +;;; will blow up in your face. You should also follow the +;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. +;;; +;;; The only communication style currently supported is NIL. +;;; +;;; Starting CCL inside emacs (with M-x slime) seems to work for me +;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 +;;; (sometimes it works, other times it hangs on start or hangs when +;;; initializing WinSock) - starting CCL externally and using M-x +;;; slime-connect always works fine. +;;; +;;; Sometimes CCL gets confused and starts giving you random memory +;;; access violation errors on startup; if this happens, try redumping +;;; your image. +;;; +;;; What works +;;; ========== +;;; * Basic editing and evaluation +;;; * Arglist display +;;; * Compilation +;;; * Loading files +;;; * apropos/describe +;;; * Debugger +;;; * Inspector +;;; +;;; TODO +;;; ==== +;;; * More debugger functionality (missing bits: restart-frame, +;;; return-from-frame, disassemble-frame, activate-stepping, +;;; toggle-trace) +;;; * XREF +;;; * Profiling +;;; * More sophisticated communication styles than NIL +;;; + +(in-package :swank-backend) + +;;; Pull in various needed bits +(require :composite-streams) +(require :sockets) +(require :winbase) +(require :lp) + +(use-package :gs) + +;; MOP stuff + +(defclass swank-mop:standard-slot-definition () + () + (:documentation "Dummy class created so that swank.lisp will compile and load.")) + +(defun named-by-gensym-p (c) + (null (symbol-package (class-name c)))) + +(deftype swank-mop:eql-specializer () + '(satisfies named-by-gensym-p)) + +(defun swank-mop:eql-specializer-object (specializer) + (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) + (loop (multiple-value-bind (more key value) + (next-entry) + (unless more (return nil)) + (when (eq specializer value) + (return key)))))) + +(defun swank-mop:class-finalized-p (class) + (declare (ignore class)) + t) + +(defun swank-mop:class-prototype (class) + (make-instance class)) + +(defun swank-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + nil) + +(defun swank-mop:generic-function-argument-precedence-order (gf) + (generic-function-lambda-list gf)) + +(defun swank-mop:generic-function-method-combination (gf) + (declare (ignore gf)) + :standard) + +(defun swank-mop:generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun swank-mop:slot-definition-documentation (slot) + (declare (ignore slot)) + (getf slot :documentation nil)) + +(defun swank-mop:slot-definition-type (slot) + (declare (ignore slot)) + t) + +(import-swank-mop-symbols :cl '(;; classes + :standard-slot-definition + :eql-specializer + :eql-specializer-object + ;; standard class readers + :class-default-initargs + :class-direct-default-initargs + :class-finalized-p + :class-prototype + :specializer-direct-methods + ;; gf readers + :generic-function-argument-precedence-order + :generic-function-declarations + :generic-function-method-combination + ;; method readers + ;; slot readers + :slot-definition-documentation + :slot-definition-type)) + +;;;; swank implementations + +;;; Debugger + +(defvar *stack-trace* nil) +(defvar *frame-trace* nil) + +(defstruct frame + name function address debug-info variables) + +(defimplementation call-with-debugging-environment (fn) + (let* ((real-stack-trace (cl::stack-trace)) + (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace + :key #'car))) + (*frame-trace* + (let* ((db::*debug-level* 1) + (db::*debug-frame-pointer* (db::stash-ebp + (ct:create-foreign-ptr))) + (db::*debug-max-level* (length real-stack-trace)) + (db::*debug-min-level* 1)) + (cdr (member #'cl:invoke-debugger + (cons + (make-frame :function nil) + (loop for i from db::*debug-min-level* + upto db::*debug-max-level* + until (eq (db::get-frame-function i) cl::*top-level*) + collect + (make-frame :function (db::get-frame-function i) + :address (db::get-frame-address i)))) + :key #'frame-function))))) + (funcall fn))) + +(defimplementation compute-backtrace (start end) + (subseq *stack-trace* start (min end (length *stack-trace*)))) + +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) + +(defun get-frame-debug-info (frame) + (let ((info (frame-debug-info frame))) + (if info + info + (setf (frame-debug-info frame) + (db::prepare-frame-debug-info (frame-function frame) + (frame-address frame)))))) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *frame-trace* frame-number)) + (info (get-frame-debug-info frame))) + (let ((var-list + (loop for i from 4 below (length info) by 2 + collect `(list :name ',(svref info i) :id 0 + :value (db::debug-filter ,(svref info i)))))) + (let ((vars (eval-in-frame `(list , at var-list) frame-number))) + (setf (frame-variables frame) vars))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (elt *frame-trace* frame-number))) + (let ((cl::*compiler-environment* (get-frame-debug-info frame))) + (eval form)))) + +(defimplementation frame-catch-tags (index) + (declare (ignore index)) + nil) + +(defimplementation frame-var-value (frame-number var) + (let ((vars (frame-variables (elt *frame-trace* frame-number)))) + (when vars + (second (elt vars var))))) + +(defimplementation frame-source-location-for-emacs (frame-number) + (fspec-location (frame-function (elt *frame-trace* frame-number)))) + +;;; Socket communication + +(defimplementation create-socket (host port) + (sockets:start-sockets) + (sockets:make-server-socket :host host :port port)) + +(defimplementation local-port (socket) + (sockets:socket-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket + &key (external-format :iso-latin-1-unix)) + (ecase external-format + (:iso-latin-1-unix + (sockets:make-socket-stream (sockets:accept-socket socket))))) + +;;; Misc + +(defimplementation preferred-communication-style () + nil) + +(defimplementation getpid () + ccl:*current-process-id*) + +(defimplementation lisp-implementation-type-name () + "cormanlisp") + +(defimplementation quit-lisp () + (sockets:stop-sockets) + (win32:exitprocess 0)) + +(defimplementation set-default-directory (directory) + (setf (ccl:current-directory) directory) + (directory-namestring (setf *default-pathname-defaults* + (truename (merge-pathnames directory))))) + +(defimplementation default-directory () + (ccl:current-directory)) + +(defimplementation macroexpand-all (form) + (ccl:macroexpand-all form)) + +;;; Documentation + +(defun fspec-location (fspec) + (when (symbolp fspec) + (setq fspec (symbol-function fspec))) + (let ((file (ccl::function-source-file fspec))) + (if file + (handler-case + (let ((truename (truename + (merge-pathnames file + ccl:*cormanlisp-directory*)))) + (make-location (list :file (namestring truename)) + (if (ccl::function-source-line fspec) + (list :line (ccl::function-source-line fspec)) + (list :function-name (princ-to-string + (function-name fspec)))))) + (error (c) (list :error (princ-to-string c)))) + (list :error (format nil "No source information available for ~S" + fspec))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defimplementation arglist (name) + (handler-case + (cond ((and (symbolp name) + (macro-function name)) + (ccl::macro-lambda-list (symbol-function name))) + (t + (when (symbolp name) + (setq name (symbol-function name))) + (if (eq (class-of name) cl::the-class-standard-gf) + (generic-function-lambda-list name) + (ccl:function-lambda-list name)))) + (error () :not-available))) + +(defimplementation function-name (fn) + (handler-case (getf (cl::function-info-list fn) 'cl::function-name) + (error () nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;; Compiler + +(defvar *buffer-name* nil) +(defvar *buffer-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +;; FIXME +(defimplementation call-with-compilation-hooks (FN) + (handler-bind ((error (lambda (c) + (signal (make-condition + 'compiler-condition + :original-condition c + :severity :warning + :message (format nil "~A" c) + :location + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :position *buffer-position*))) + (*compile-filename* + (make-location + (list :file *compile-filename*) + (list :position 1))) + (t + (list :error "No location")))))))) + (funcall fn))) + +(defimplementation swank-compile-file (*compile-filename* load-p) + (with-compilation-hooks () + (let ((*buffer-name* nil)) + (compile-file *compile-filename*) + (when load-p + (load (compile-file-pathname *compile-filename*)))))) + +(defimplementation swank-compile-string (string &key buffer position directory) + (declare (ignore directory)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string))))))) + +;;;; Inspecting + +(defclass corman-inspector (inspector) + ()) + +(defimplementation make-default-inspector () + (make-instance 'corman-inspector)) + +(defun comma-separated (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast (loop for e in list + collect (funcall callback e) + collect ", "))) + +(defimplementation inspect-for-emacs ((class standard-class) + (inspector corman-inspector)) + (declare (ignore inspector)) + (values "A class." + `("Name: " (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(comma-separated (swank-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(comma-separated + (swank-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated + (swank-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string + (swank-mop:slot-definition-name slot))))) + '("#")) + (:newline) + ,@(when (documentation class t) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(comma-separated (swank-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(princ-to-string (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (swank-mop:class-finalized-p class) + (comma-separated (swank-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(princ-to-string (class-name class))))) + '("#")) + (:newline)))) + +(defimplementation inspect-for-emacs ((slot cons) (inspector corman-inspector)) + ;; Inspects slot definitions + (declare (ignore corman-inspector)) + (if (eq (car slot) :name) + (values "A slot." + `("Name: " (:value ,(swank-mop:slot-definition-name slot)) + (:newline) + ,@(when (swank-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(swank-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) + "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) + `(:value ,(swank-mop:slot-definition-initform slot)) + "#") (:newline) + "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) + (:newline))) + (call-next-method))) + +(defimplementation inspect-for-emacs ((pathname pathnames::pathname-internal) + inspector) + (declare (ignore inspector)) + (values (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +;;; This is probably not good, but it WFM +(in-package :common-lisp) + +(defvar *old-documentation* #'documentation) +(defun documentation (thing &optional (type 'function)) + (if (symbolp thing) + (funcall *old-documentation* thing type) + (values))) + +(defmethod print-object ((restart restart) stream) + (if (or *print-escape* + *print-readably*) + (print-unreadable-object (restart stream :type t :identity t) + (princ (restart-name restart) stream)) + (when (functionp (restart-report-function restart)) + (funcall (restart-report-function restart) stream)))) Index: slime/ChangeLog diff -u slime/ChangeLog:1.708 slime/ChangeLog:1.709 --- slime/ChangeLog:1.708 Fri Jun 3 22:00:28 2005 +++ slime/ChangeLog Tue Jun 7 12:08:04 2005 @@ -1,3 +1,15 @@ +2005-06-07 Espen Wiborg + + * swank-corman.lisp: Convert to Unix line-endings. + (create-socket): Pass through the port argument unmodified, + gettting a random port if 0. Requires supporting change in + /modules/sockets.lisp. + (inspect-for-emacs): defimplementation instead of defmethod. + +2005-06-06 Espen Wiborg + + * doc/slime.texi, PROBLEMS: Added notes about CCL. + 2005-06-03 Helmut Eller * slime.el (slime-background-activities-enabled-p): Allow From crhodes at common-lisp.net Tue Jun 28 08:40:09 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 28 Jun 2005 10:40:09 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/PROBLEMS slime/swank-sbcl.lisp Message-ID: <20050628084009.45AA688525@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29109 Modified Files: ChangeLog PROBLEMS swank-sbcl.lisp Log Message: Support sbcl 0.9.2 Date: Tue Jun 28 10:40:08 2005 Author: crhodes Index: slime/ChangeLog diff -u slime/ChangeLog:1.716 slime/ChangeLog:1.717 --- slime/ChangeLog:1.716 Tue Jun 21 20:28:58 2005 +++ slime/ChangeLog Tue Jun 28 10:40:07 2005 @@ -1,3 +1,8 @@ +2005-06-28 Gabor Melis + + * swank-sbcl.lisp (threaded stuff): horrible hack to make threaded + SBCL 0.9.2 work. (also, Happy Birthday Christophe!) + 2005-06-21 Edi Weitz * swank.lisp (find-matching-packages): Also use nicknames. Index: slime/PROBLEMS diff -u slime/PROBLEMS:1.6 slime/PROBLEMS:1.7 --- slime/PROBLEMS:1.6 Tue Jun 7 12:06:51 2005 +++ slime/PROBLEMS Tue Jun 28 10:40:07 2005 @@ -21,8 +21,9 @@ ** SBCL -SBCL versions from 0.8.15 to 0.8.21 should work. Newer SBCL's may or -may not work. Don't use multithreading with 2.4 kernels. +The latest released version of SBCL at the time of packaging should +work. Older or newer SBCLs may or may not work. Do not use +multithreading with unpatched 2.4 Linux kernels. The (v)iew-source command in the debugger can only locate exact source forms for code compiled at (debug 2) or higher. The default level is Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.134 slime/swank-sbcl.lisp:1.135 --- slime/swank-sbcl.lisp:1.134 Sat Jun 11 18:22:23 2005 +++ slime/swank-sbcl.lisp Tue Jun 28 10:40:07 2005 @@ -1095,14 +1095,15 @@ (defimplementation startup-multiprocessing ()) (defimplementation thread-id (thread) - thread) + (assert (eql (ash (ash thread -5) 5) thread)) + (ash thread -5)) (defimplementation find-thread (id) - (if (member id (all-threads)) - id)) + (when (member (ash id 5) (all-threads)) + (ash id 5))) (defimplementation thread-name (thread) - (format nil "Thread ~D" thread)) + (format nil "Thread ~D" (thread-id thread))) (defun %thread-state-slot (thread) (sb-sys:without-gcing @@ -1133,12 +1134,13 @@ (sb-thread:current-thread-id)) (defimplementation all-threads () - (let ((pids (sb-sys:without-gcing + (let ((tids (sb-sys:without-gcing (sb-thread::mapcar-threads (lambda (sap) - (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes - sb-vm::thread-pid-slot))))))) - (remove :dead pids :key #'%thread-state))) + (sb-sys:sap-ref-32 sap + (* sb-vm:n-word-bytes + sb-vm::thread-os-thread-slot))))))) + (remove :dead tids :key #'%thread-state))) (defimplementation interrupt-thread (thread fn) (sb-thread:interrupt-thread thread fn))