From heller at common-lisp.net Sun Nov 10 07:56:21 2013 From: heller at common-lisp.net (CVS User heller) Date: Sat, 9 Nov 2013 23:56:21 -0800 (PST) Subject: CVS slime Message-ID: <20131110075621.528563565EB@mail.common-lisp.net> Update of /project/slime/cvsroot/slime In directory alpha-cl-net:/tmp/cvs-serv7720 Modified Files: ChangeLog slime.el swank.lisp Log Message: * swank.lisp (swank-profile-package): New wrapper for profile-package that does some input validation. * slime.el (slime-profile-package): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2013/11/01 15:38:50 1.2409 +++ /project/slime/cvsroot/slime/ChangeLog 2013/11/10 07:56:20 1.2410 @@ -1,3 +1,9 @@ +2013-11-10 Helmut Eller + + * swank.lisp (swank-profile-package): New wrapper for + profile-package that does some input validation. + * slime.el (slime-profile-package): Use it. + 2013-11-01 Helmut Eller * swank-ccl.lisp (p2-definitions): Check bounds before accessing --- /project/slime/cvsroot/slime/slime.el 2013/04/23 16:37:14 1.1430 +++ /project/slime/cvsroot/slime/slime.el 2013/11/10 07:56:20 1.1431 @@ -800,8 +800,8 @@ (defun slime-read-package-name (prompt &optional initial-value) "Read a package name from the minibuffer, prompting with PROMPT." (let ((completion-ignore-case t)) - (completing-read prompt (slime-bogus-completion-alist - (slime-eval + (completing-read prompt (slime-bogus-completion-alist + (slime-eval `(swank:list-all-package-names t))) nil t initial-value))) @@ -4490,15 +4490,15 @@ (lambda (r) (message "%s" r)))) (defun slime-profile-package (package callers methods) - "Profile all functions in PACKAGE. + "Profile all functions in PACKAGE. If CALLER is non-nil names have counts of the most common calling -functions recorded. +functions recorded. If METHODS is non-nil, profile all methods of all generic function having names in the given package." (interactive (list (slime-read-package-name "Package: ") (y-or-n-p "Record the most common callers? ") (y-or-n-p "Profile methods? "))) - (slime-eval-async `(swank:profile-package ,package ,callers ,methods) + (slime-eval-async `(swank:swank-profile-package ,package ,callers ,methods) (lambda (r) (message "%s" r)))) (defun slime-profile-by-substring (substring &optional package) --- /project/slime/cvsroot/slime/swank.lisp 2013/01/11 09:00:30 1.803 +++ /project/slime/cvsroot/slime/swank.lisp 2013/11/10 07:56:21 1.804 @@ -13,7 +13,7 @@ (defpackage :swank (:use :cl :swank-backend :swank-match :swank-rpc) (:export #:startup-multiprocessing - #:start-server + #:start-server #:create-server #:stop-server #:restart-server @@ -2910,6 +2910,13 @@ (maybe-profile symbol)))) (format nil "~a function~:p ~:*~[are~;is~:;are~] now profiled" count))) +(defslimefun swank-profile-package (package-name callersp methodsp) + (let ((pkg (or (guess-package package-name) + (error "Not a valid package name: ~s" package-name)))) + (check-type callersp boolean) + (check-type methodsp boolean) + (profile-package pkg callersp methodsp))) + ;;;; Source Locations From heller at common-lisp.net Fri Nov 1 15:38:50 2013 From: heller at common-lisp.net (CVS User heller) Date: Fri, 1 Nov 2013 08:38:50 -0700 (PDT) Subject: CVS slime Message-ID: <20131101153850.6410135667C@mail.common-lisp.net> Update of /project/slime/cvsroot/slime In directory alpha-cl-net:/tmp/cvs-serv12537 Modified Files: ChangeLog swank-ccl.lisp Log Message: * swank-ccl.lisp (p2-definitions): Check bounds before accessing backend-p2-dispatch. --- /project/slime/cvsroot/slime/ChangeLog 2013/11/01 14:42:09 1.2408 +++ /project/slime/cvsroot/slime/ChangeLog 2013/11/01 15:38:50 1.2409 @@ -1,5 +1,10 @@ 2013-11-01 Helmut Eller + * swank-ccl.lisp (p2-definitions): Check bounds before accessing + backend-p2-dispatch. + +2013-11-01 Helmut Eller + * swank-sbcl.lisp (swank-compile-string): Fix last commit. Honor *trap-load-time-warnings* but without calling LOAD inside WITH-COMPILATION-UNIT. --- /project/slime/cvsroot/slime/swank-ccl.lisp 2013/09/29 13:45:42 1.34 +++ /project/slime/cvsroot/slime/swank-ccl.lisp 2013/11/01 15:38:50 1.35 @@ -552,10 +552,11 @@ (defun p2-definitions (name) (let ((nx1-op (gethash name ccl::*nx1-operators*))) (and nx1-op - (let ((p2 (aref (ccl::backend-p2-dispatch ccl::*target-backend*) - nx1-op))) - (and p2 - (ccl:find-definition-sources p2)))))) + (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) + (and (array-in-bounds-p dispatch nx1-op) + (let ((p2 (aref dispatch nx1-op))) + (and p2 + (ccl:find-definition-sources p2)))))))) (defimplementation find-definitions (name) (let ((defs (append (or (ccl:find-definition-sources name) From heller at common-lisp.net Sun Nov 10 08:11:44 2013 From: heller at common-lisp.net (CVS User heller) Date: Sun, 10 Nov 2013 00:11:44 -0800 (PST) Subject: CVS slime Message-ID: <20131110081145.1B2483565EB@mail.common-lisp.net> Update of /project/slime/cvsroot/slime In directory alpha-cl-net:/tmp/cvs-serv16659 Modified Files: ChangeLog slime.el swank.lisp Log Message: * slime.el (slime-delete-package): New command. * swank.lisp (swank-delete-package): The corresponding Swank part. --- /project/slime/cvsroot/slime/ChangeLog 2013/11/10 07:56:20 1.2410 +++ /project/slime/cvsroot/slime/ChangeLog 2013/11/10 08:11:44 1.2411 @@ -1,5 +1,10 @@ 2013-11-10 Helmut Eller + * slime.el (slime-delete-package): New command. + * swank.lisp (swank-delete-package): The corresponding Swank part. + +2013-11-10 Helmut Eller + * swank.lisp (swank-profile-package): New wrapper for profile-package that does some input validation. * slime.el (slime-profile-package): Use it. --- /project/slime/cvsroot/slime/slime.el 2013/11/10 07:56:20 1.1431 +++ /project/slime/cvsroot/slime/slime.el 2013/11/10 08:11:44 1.1432 @@ -4421,6 +4421,13 @@ (slime-eval-async `(swank:unintern-symbol ,symbol-name ,package) (lambda (result) (message "%s" result)))) +(defun slime-delete-package (package-name) + "Delete the package with name PACKAGE-NAME." + (interactive (list (slime-read-package-name "Delete package: " + (slime-current-package)))) + (slime-eval-async `(cl:delete-package + (swank::guess-package ,package-name)))) + (defun slime-load-file (filename) "Load the Lisp file FILENAME." (interactive (list --- /project/slime/cvsroot/slime/swank.lisp 2013/11/10 07:56:21 1.804 +++ /project/slime/cvsroot/slime/swank.lisp 2013/11/10 08:11:44 1.805 @@ -2869,7 +2869,7 @@ (defslimefun unintern-symbol (name package) (let ((pkg (guess-package package))) (cond ((not pkg) (format nil "No such package: ~s" package)) - (t + (t (multiple-value-bind (sym found) (parse-symbol name pkg) (case found ((nil) (format nil "~s not in package ~s" name package)) @@ -2877,6 +2877,12 @@ (unintern sym pkg) (format nil "Uninterned symbol: ~s" sym)))))))) +(defslimefun swank-delete-package (package-name) + (let ((pkg (or (guess-package package-name) + (error "No such package: ~s" package-name)))) + (delete-package pkg) + nil)) + ;;;; Profiling From heller at common-lisp.net Sun Nov 17 07:59:04 2013 From: heller at common-lisp.net (CVS User heller) Date: Sat, 16 Nov 2013 23:59:04 -0800 (PST) Subject: CVS slime Message-ID: <20131117075904.6FED7356695@mail.common-lisp.net> Update of /project/slime/cvsroot/slime In directory alpha-cl-net:/tmp/cvs-serv16332 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (swank-compile-string): Load the fasl file even if there were warnings. Just like the other backends do. --- /project/slime/cvsroot/slime/ChangeLog 2013/11/10 08:11:44 1.2411 +++ /project/slime/cvsroot/slime/ChangeLog 2013/11/17 07:59:04 1.2412 @@ -1,3 +1,8 @@ +2013-11-17 Helmut Eller + + * swank-sbcl.lisp (swank-compile-string): Load the fasl file even + if there were warnings. Just like the other backends do. + 2013-11-10 Helmut Eller * slime.el (slime-delete-package): New command. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2013/11/01 14:42:09 1.330 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2013/11/17 07:59:04 1.331 @@ -676,7 +676,9 @@ (*buffer-substring* string) (*buffer-tmpfile* (temp-file-name))) (labels ((load-it (filename) - (when filename (load filename))) + (cond (*trap-load-time-warnings* + (with-compilation-hooks () (load filename))) + (t (load filename)))) (cf () (with-compiler-policy policy (with-compilation-unit @@ -686,20 +688,17 @@ :emacs-position position) :source-namestring filename :allow-other-keys t) - (compile-file *buffer-tmpfile* :external-format :utf-8)))) - (compile-it (cont) - (with-compilation-hooks () - (multiple-value-bind (output-file warningsp failurep) (cf) - (declare (ignore warningsp)) - (unless failurep - (funcall cont output-file)))))) + (compile-file *buffer-tmpfile* :external-format :utf-8))))) (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error :external-format :utf-8) (write-string string s)) (unwind-protect - (if *trap-load-time-warnings* - (compile-it #'load-it) - (load-it (compile-it #'identity))) + (multiple-value-bind (output-file warningsp failurep) + (with-compilation-hooks () (cf)) + (declare (ignore warningsp)) + (when output-file + (load-it output-file)) + (not failurep)) (ignore-errors (delete-file *buffer-tmpfile*) (delete-file (compile-file-pathname *buffer-tmpfile*))))))) From heller at common-lisp.net Fri Nov 1 14:42:09 2013 From: heller at common-lisp.net (CVS User heller) Date: Fri, 1 Nov 2013 07:42:09 -0700 (PDT) Subject: CVS slime Message-ID: <20131101144210.0B97735664C@mail.common-lisp.net> Update of /project/slime/cvsroot/slime In directory alpha-cl-net:/tmp/cvs-serv10359 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (swank-compile-string): Fix last commit. Honor *trap-load-time-warnings* but without calling LOAD inside WITH-COMPILATION-UNIT. --- /project/slime/cvsroot/slime/ChangeLog 2013/10/31 07:55:49 1.2407 +++ /project/slime/cvsroot/slime/ChangeLog 2013/11/01 14:42:09 1.2408 @@ -1,3 +1,9 @@ +2013-11-01 Helmut Eller + + * swank-sbcl.lisp (swank-compile-string): Fix last commit. Honor + *trap-load-time-warnings* but without calling LOAD inside + WITH-COMPILATION-UNIT. + 2013-10-31 Helmut Eller * swank-sbcl.lisp (swank-compile-string): Don't call LOAD inside --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2013/10/31 07:55:49 1.329 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2013/11/01 14:42:09 1.330 @@ -607,9 +607,6 @@ (warning #'handle-notification-condition)) (funcall function))) - -(defvar *trap-load-time-warnings* t) - (defun compiler-policy (qualities) "Return compiler policy qualities present in the QUALITIES alist. QUALITIES is an alist with (quality . value)" @@ -633,7 +630,7 @@ (unwind-protect (progn , at body) (setf (compiler-policy) ,current-policy))))) -(defimplementation swank-compile-file (input-file output-file +(defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (multiple-value-bind (output-file warnings-p failure-p) @@ -645,7 +642,7 @@ (or failure-p (when load-p ;; Cache the latest source file for definition-finding. - (source-cache-get input-file + (source-cache-get input-file (file-write-date input-file)) (not (load output-file))))))) @@ -670,36 +667,39 @@ "Return a temporary file name to compile strings into." (tempnam nil nil)) +(defvar *trap-load-time-warnings* t) + (defimplementation swank-compile-string (string &key buffer position filename policy) (let ((*buffer-name* buffer) (*buffer-offset* position) (*buffer-substring* string) (*buffer-tmpfile* (temp-file-name))) - (flet ((load-it (filename) - (when filename (load filename))) - (compile-it (cont) - (multiple-value-bind (output-file warningsp failurep) - (with-compilation-hooks () - (with-compilation-unit - (:source-plist (list :emacs-buffer buffer - :emacs-filename filename - :emacs-string string - :emacs-position position) - :source-namestring filename - :allow-other-keys t) - (compile-file *buffer-tmpfile* :external-format :utf-8))) - (declare (ignore warningsp)) - (unless failurep - (funcall cont output-file))))) + (labels ((load-it (filename) + (when filename (load filename))) + (cf () + (with-compiler-policy policy + (with-compilation-unit + (:source-plist (list :emacs-buffer buffer + :emacs-filename filename + :emacs-string string + :emacs-position position) + :source-namestring filename + :allow-other-keys t) + (compile-file *buffer-tmpfile* :external-format :utf-8)))) + (compile-it (cont) + (with-compilation-hooks () + (multiple-value-bind (output-file warningsp failurep) (cf) + (declare (ignore warningsp)) + (unless failurep + (funcall cont output-file)))))) (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error :external-format :utf-8) (write-string string s)) (unwind-protect - (with-compiler-policy policy - (if *trap-load-time-warnings* - (compile-it #'load-it) - (load-it (compile-it #'identity)))) + (if *trap-load-time-warnings* + (compile-it #'load-it) + (load-it (compile-it #'identity))) (ignore-errors (delete-file *buffer-tmpfile*) (delete-file (compile-file-pathname *buffer-tmpfile*)))))))