From heller at common-lisp.net Tue Apr 1 12:10:21 2008 From: heller at common-lisp.net (heller) Date: Tue, 1 Apr 2008 07:10:21 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080401121021.8AA8D44056@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv10064 Modified Files: swank-kawa.scm Log Message: swank-kawa.scm: Implement quit-thread-browser. --- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/03/27 11:46:52 1.5 +++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/04/01 12:10:21 1.6 @@ -23,7 +23,7 @@ :init kawa-slime-init))) (defun kawa-slime-init (file _) - (setq slime-protocol-version nil) + (setq slime-protocol-version 'ignore) (let ((zip ".../slime/contrib/swank-kawa.zip")) ; <-- insert the right path (format "%S\n" `(begin (load ,(expand-file-name zip)) (start-swank ,file))))) @@ -390,6 +390,8 @@ (send dbg `(list-threads ,id))) ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _ _ _)) (send dbg `(debug-nth-thread ,n))) + ((_ (':emacs-rex ('|swank:quit-thread-browser|) _ _ id)) + (send dbg `(quit-thread-browser ,id))) ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id)) (set inspector (make-inspector user-env (vm))) (send inspector `(init ,str ,id))) @@ -450,7 +452,7 @@ ;;;; Reader thread (df reader ((in ) (c )) - (! set-name (current-thread) "swank-reader") + (! set-name (current-thread) "swank-net-reader") (let ((rt (gnu.kawa.lispexpr.ReadTable:createInitial))) ; ':' not special (while #t (send c (decode-message in rt))))) @@ -482,7 +484,7 @@ ;;;; Writer thread (df writer ((out ) (c )) - (! set-name (current-thread) "swank-writer") + (! set-name (current-thread) "swank-net-writer") (while #t (encode-message out (recv c)))) @@ -554,22 +556,23 @@ ;;;; Listener (df listener ((c ) (env )) - (! set-name (current-thread) "listener") + (! set-name (current-thread) "swank-listener") (log "listener: ~s ~s ~s ~s\n" (current-thread) ((current-thread):hashCode) c env) - (let ((out (rpc c `(get-channel)))) - (set (current-output-port) (make-swank-outport out))) - (let ((vm (as (rpc c `(get-vm))))) - (send c `(set-listener ,(vm-mirror vm (current-thread)))) - (enable-uncaught-exception-events vm)) - (rpc c `(get-vm)) - (listener-loop c env)) + (let ((out (make-swank-outport (rpc c `(get-channel))))) + (set (current-output-port) out) + (let ((vm (as (rpc c `(get-vm))))) + (send c `(set-listener ,(vm-mirror vm (current-thread)))) + (enable-uncaught-exception-events vm)) + (rpc c `(get-vm)) + (listener-loop c env out))) -(df listener-loop ((c ) (env )) +(df listener-loop ((c ) (env ) port) (while (not (nul? c)) ;;(log "listener-loop: ~s ~s\n" (current-thread) c) (mlet ((form id) (recv c)) (let ((restart (fun () + (close-output-port port) (reply-abort c id) (send (car (spawn/chan (fun (cc) @@ -1101,16 +1104,22 @@ (q :: :init ( (as 100))) ((*init*) (invoke-special (this) '*init*)) ((write (buffer ) (from ) (to )) :: - (! put q `(write ,( buffer from to)))) + (synchronized (this) + (assert (not (== q #!null))) + (! put q `(write ,( buffer from to))))) ((close) :: - (! put q 'close)) + (synchronized (this) + (! put q 'close) + (set! q #!null))) ((flush) :: - (let ((ex ())) - (! put q `(flush ,ex)) - (! exchange ex #!null)))) + (synchronized (this) + (assert (not (== q #!null))) + (let ((ex ())) + (! put q `(flush ,ex)) + (! exchange ex #!null))))) (df swank-writer ((in ) (q )) - (! set-name (current-thread) "redirect thread") + (! set-name (current-thread) "swank-redirect-thread") (let* ((out (as (recv in))) (builder ()) (flush (fun () @@ -1128,7 +1137,9 @@ (('flush ex) (flush) (! exchange (as ex) #!null)) - ('close (set closed #t)))))) + ('close + (set closed #t) + (flush)))))) (df make-swank-outport ((out )) (let ((w ())) @@ -1140,7 +1151,7 @@ ;;;; Monitor (df vm-monitor ((c )) - (! set-name (current-thread) "vm-monitor") + (! set-name (current-thread) "swank-vm-monitor") (let ((vm (vm-attach))) ;;(enable-uncaught-exception-events vm) (mlet* (((ev . _) (spawn/chan/catch @@ -1179,6 +1190,9 @@ (let ((t (nth (get state 'all-threads #f) n))) ;;(log "thread ~d : ~a\n" n t) (set state (debug-thread t state c)))) + ((,c . ('quit-thread-browser id)) + (reply c 't id) + (set state (del state 'all-threads))) ((,ev . ('vm-event es)) ;;(log "vm-events: len=~a\n" (len es)) (for (((e ) (as es))) From trittweiler at common-lisp.net Sun Apr 6 09:58:18 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 6 Apr 2008 05:58:18 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080406095818.1B5245C16F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18385 Modified Files: slime.el Log Message: * slime.el (slime-edit-definition): The `slime-edit-definition-hooks' are now invoked with the same args as `slime-edit-definition'. --- /project/slime/cvsroot/slime/slime.el 2008/03/27 11:46:50 1.935 +++ /project/slime/cvsroot/slime/slime.el 2008/04/06 09:58:17 1.936 @@ -5045,6 +5045,11 @@ (defun slime-xref-has-location-p (xref) (slime-location-p (slime-xref.location xref))) + +;;; The hooks are tried in order until one succeeds, otherwise the +;;; default implementation involving `slime-find-definitions-function' +;;; is used. The hooks are called with the same arguments as +;;; `slime-edit-definition'. (defvar slime-edit-definition-hooks) (defun slime-edit-definition (name &optional where) @@ -5052,7 +5057,7 @@ If there's no name at point, or a prefix argument is given, then the function name is prompted." (interactive (list (slime-read-symbol-name "Name: "))) - (or (run-hook-with-args-until-success 'slime-edit-definition-hooks (point)) + (or (run-hook-with-args-until-success 'slime-edit-definition-hooks name where) (slime-edit-definition-cont (slime-find-definitions name) name where))) From trittweiler at common-lisp.net Sun Apr 6 09:58:40 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 6 Apr 2008 05:58:40 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080406095840.E22D6601AD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18432 Modified Files: ChangeLog Log Message: * slime.el (slime-edit-definition): The `slime-edit-definition-hooks' are now invoked with the same args as `slime-edit-definition'. --- /project/slime/cvsroot/slime/ChangeLog 2008/03/27 21:59:45 1.1341 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/06 09:58:40 1.1342 @@ -1,9 +1,14 @@ +2008-04-06 Tobias C. Rittweiler + + * slime.el (slime-edit-definition): The `slime-edit-definition-hooks' + are now invoked with the same args as `slime-edit-definition'. + 2008-03-27 Martin Simmons * swank-lispworks.lisp (map-error-database): Make mapping work for LispWorks 5.1 too. -2008-03-26 Tobias C. Rittweiler +2008-03-26 Tobias C. Rittweiler On SBCL, From trittweiler at common-lisp.net Sun Apr 6 10:02:25 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 6 Apr 2008 06:02:25 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080406100225.B046E25116@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv21196/contrib Modified Files: slime-presentations.el Log Message: * slime-presentations.lisp: (slime-maybe-M-.-presentation-at-point): Renamed to `slime-edit-presentation'. Now makes sure to decline if user gave a name explicitly. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/03/02 15:21:42 1.14 +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/04/06 10:02:24 1.15 @@ -375,7 +375,7 @@ (slime-inspect-presentation presentation start end (current-buffer)))) -(defun slime-M-.-presentation (presentation start end buffer) +(defun slime-M-.-presentation (presentation start end buffer &optional where) (let* ((id (slime-presentation-id presentation)) (presentation-string (format "Presentation %s" id)) (location (slime-eval `(swank:find-definition-for-thing @@ -385,7 +385,7 @@ (and location (list (make-slime-xref :dspec `(,presentation-string) :location location))) presentation-string - nil))) + where))) (defun slime-M-.-presentation-at-mouse (event) (interactive "e") @@ -399,12 +399,13 @@ (slime-presentation-around-or-before-point-or-error point) (slime-M-.-presentation presentation start end (current-buffer)))) -(defun slime-maybe-M-.-presentation-at-point (point) - (interactive "d") - (multiple-value-bind (presentation start end whole-p) - (slime-presentation-around-or-before-point point) - (when presentation - (slime-M-.-presentation presentation start end (current-buffer))))) +(defun slime-edit-presentation (name &optional where) + (if (or current-prefix-arg (not (equal (slime-symbol-name-at-point) name))) + nil ; NAME came from user explicitly, so decline. + (multiple-value-bind (presentation start end whole-p) + (slime-presentation-around-or-before-point (point)) + (when presentation + (slime-M-.-presentation presentation start end (current-buffer) where))))) (defun slime-copy-presentation-to-repl (presentation start end buffer) @@ -866,7 +867,7 @@ (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open) (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations) (add-hook 'slime-connected-hook 'slime-install-presentations) - (add-hook 'slime-edit-definition-hooks 'slime-maybe-M-.-presentation-at-point) + (add-hook 'slime-edit-definition-hooks 'slime-edit-presentation) (setq slime-inspector-insert-ispec-function 'slime-presentation-inspector-insert-ispec) (setq sldb-insert-frame-variable-value-function 'slime-presentation-sldb-insert-frame-variable-value) From trittweiler at common-lisp.net Sun Apr 6 10:02:38 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Sun, 6 Apr 2008 06:02:38 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080406100238.8466B64114@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv21266/contrib Modified Files: ChangeLog Log Message: * slime-presentations.lisp: (slime-maybe-M-.-presentation-at-point): Renamed to `slime-edit-presentation'. Now makes sure to decline if user gave a name explicitly. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/03/24 07:22:20 1.102 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/04/06 10:02:35 1.103 @@ -1,3 +1,10 @@ +2008-04-06 Tobias C. Rittweiler + + * slime-presentations.lisp: + (slime-maybe-M-.-presentation-at-point): Renamed to + `slime-edit-presentation'. Now makes sure to decline if user gave + a name explicitly. + 2008-03-24 Helmut Eller * swank-kawa.scm: Save stacktraces with locals on throw events. From mbaringer at common-lisp.net Mon Apr 14 11:36:18 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 14 Apr 2008 07:36:18 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080414113618.6C00775150@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv23359 Modified Files: swank-arglists.lisp ChangeLog Log Message: (decode-arglist): Arglists can be dotted lists. --- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/02/04 17:58:31 1.20 +++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/04/14 11:36:16 1.21 @@ -585,65 +585,71 @@ (defun decode-arglist (arglist) "Parse the list ARGLIST and return an ARGLIST structure." - (let ((mode nil) - (result (make-arglist))) - (dolist (arg arglist) - (cond - ((eql mode '&unknown-junk) - ;; don't leave this mode -- we don't know how the arglist - ;; after unknown lambda-list keywords is interpreted - (push arg (arglist.unknown-junk result))) - ((eql arg '&allow-other-keys) - (setf (arglist.allow-other-keys-p result) t)) - ((eql arg '&key) - (setf (arglist.key-p result) t - mode arg)) - ((member arg '(&optional &rest &body &aux)) - (setq mode arg)) - ((member arg '(&whole &environment)) - (setq mode arg) - (push arg (arglist.known-junk result))) - ((and (symbolp arg) - (string= (symbol-name arg) (string '#:&any))) ; may be interned - (setf (arglist.any-p result) t) ; in any *package*. - (setq mode '&any)) - ((member arg lambda-list-keywords) - (setq mode '&unknown-junk) - (push arg (arglist.unknown-junk result))) - (t - (ecase mode - (&key - (push (decode-keyword-arg arg) - (arglist.keyword-args result))) - (&optional - (push (decode-optional-arg arg) - (arglist.optional-args result))) - (&body - (setf (arglist.body-p result) t - (arglist.rest result) arg)) - (&rest - (setf (arglist.rest result) arg)) - (&aux - (push (decode-optional-arg arg) - (arglist.aux-args result))) - ((nil) - (push (decode-required-arg arg) - (arglist.required-args result))) - ((&whole &environment) - (setf mode nil) - (push arg (arglist.known-junk result))) - (&any - (push arg (arglist.any-args result))))))) - (nreversef (arglist.required-args result)) - (nreversef (arglist.optional-args result)) - (nreversef (arglist.keyword-args result)) - (nreversef (arglist.aux-args result)) - (nreversef (arglist.any-args result)) - (nreversef (arglist.known-junk result)) - (nreversef (arglist.unknown-junk result)) - (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result))) - (exactly-one-p (arglist.key-p result) (arglist.any-p result)))) - result)) + (loop + with mode = nil + with result = (make-arglist) + for arg = (if (consp arglist) + (pop arglist) + (progn + (setf mode '&rest) + arglist)) + do (cond + ((eql mode '&unknown-junk) + ;; don't leave this mode -- we don't know how the arglist + ;; after unknown lambda-list keywords is interpreted + (push arg (arglist.unknown-junk result))) + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((member arg '(&optional &rest &body &aux)) + (setq mode arg)) + ((member arg '(&whole &environment)) + (setq mode arg) + (push arg (arglist.known-junk result))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&any))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) + ((member arg lambda-list-keywords) + (setq mode '&unknown-junk) + (push arg (arglist.unknown-junk result))) + (t + (ecase mode + (&key + (push (decode-keyword-arg arg) + (arglist.keyword-args result))) + (&optional + (push (decode-optional-arg arg) + (arglist.optional-args result))) + (&body + (setf (arglist.body-p result) t + (arglist.rest result) arg)) + (&rest + (setf (arglist.rest result) arg)) + (&aux + (push (decode-optional-arg arg) + (arglist.aux-args result))) + ((nil) + (push (decode-required-arg arg) + (arglist.required-args result))) + ((&whole &environment) + (setf mode nil) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result)))))) + until (atom arglist) + finally (nreversef (arglist.required-args result)) + finally (nreversef (arglist.optional-args result)) + finally (nreversef (arglist.keyword-args result)) + finally (nreversef (arglist.aux-args result)) + finally (nreversef (arglist.any-args result)) + finally (nreversef (arglist.known-junk result)) + finally (nreversef (arglist.unknown-junk result)) + finally (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) (arglist.any-p result)))) + finally (return result))) (defun encode-arglist (decoded-arglist) (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist)) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/04/06 10:02:35 1.103 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/04/14 11:36:17 1.104 @@ -1,3 +1,8 @@ +2008-04-14 Marco Baringer + + * swank-arglists.lisp (decode-arglist): Arglists can be dotted + lists. + 2008-04-06 Tobias C. Rittweiler * slime-presentations.lisp: From mbaringer at common-lisp.net Mon Apr 14 21:31:21 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 14 Apr 2008 17:31:21 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080414213121.067DC3001B@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv26158/contrib Modified Files: slime-indentation.el ChangeLog Log Message: (cl-indent::line-number): new function. (cl-indent:indent-cond): Custom indentation method for cl:cond. (cl-indent-body-introducing-loop-macro-keyword) (cl-indent-indented-loop-macro-keyword): more loop keywords. (cl-indent-loop-advance-past-keyword-on-line): deal with comments after loop keywords. (#'define-cl-indent): Fix indentation of handler-case; give cond it's custom indentation method; change indentation of defclass; add methods for do-all-symbols, do-symbols, do-external-symbols, restart-case, with-accessors, with-compilation-unit, with-hash-table-iterator, with-output-to-string, with-input-from-string, with-open-file, with-open-stream, with-package-iterator, with-simple-restart, with-slots. --- /project/slime/cvsroot/slime/contrib/slime-indentation.el 2008/02/03 18:45:14 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-indentation.el 2008/04/14 21:31:20 1.2 @@ -378,7 +378,6 @@ (defun cl-indent::normal (state) "Compute normal indentation according to STATE and current position." - ;; Actually, the current column (i.e., the normal point) _is_ a good ;; approximation for the normal indentation. But lists with a list ;; as the first element make problems if an &rest or an &body method @@ -505,9 +504,7 @@ normal-indent))) ((eq tem '&rest) ;; this pattern holds for all remaining forms - (setf method (let ((rest (cons (second method) nil))) - (setf (cdr rest) rest) - rest) + (setf method (list (second method)) n 0)) ((> n 0) ;; try next element of pattern @@ -685,6 +682,71 @@ method path state indent-point sexp-column normal-indent))) +(defun cl-indent::line-number () + "Compatability implementation of emacs23's line-number-at-pos." + (cond + ((fboundp 'line-number-at-pos) + (line-number-at-pos)) + ((fboundp 'line-number) + (line-number nil t)) + ((fboundp 'count-lines) + (count-lines (point-min) (point))) + (t + (error "Don't know how to count the number of lines from the start of the (narrowed) buffer to point.")))) + +(defun cl-indent:indent-cond (path state indent-point sexp-column normal-indent) + "Handle indentation of cond. + +Cond is either (&rest (&whole 2 1 &rest 1)) or (&rest (&whole 6 1 +&rest 1)) depending on whether the first caluse is or isn't on +the same line as the cond symbol. + +So if we have: + + (cond (a b) + | + +we line up the clauses after the cond symbol (6 space of +indentation). wherease if we have: + + (cond + (a b) + |) + +we line up the clauses two space past the form's indentation." + ;; i'd bet my left pinky there's a better way to implement this... + (let (cond-line-number first-clause-line-number method here) + (save-excursion + ;; narrow to the aera we're interested in because + ;; cl-indent::line-number can, especially on tramp files, be + ;; very slow. + (save-restriction + (narrow-to-region (save-excursion + (backward-up-list) + (point)) + (point)) + (setf here (point)) + (backward-up-list) + (setf cond-line-number (cl-indent::line-number)) + (down-list) + (forward-sexp 1) + (setf first-clause-line-number + (progn + (if (= 1 (first path)) + ;; we're indenting the first form. use the current line. + (goto-char here) + ;; we're indenting some form which isn't the + ;; first. find out which the line the first clause + ;; starts on. + (forward-sexp 1) + (backward-sexp 1)) + (cl-indent::line-number))))) + (cl-indent::form-method + (if (= cond-line-number first-clause-line-number) + '(&rest (&whole 6 &rest 1)) + '(&rest (&whole 2 &rest 1))) + path state indent-point sexp-column normal-indent))) + ;;; ============================================================ ;;; @@ -771,7 +833,7 @@ ;; Regexps matching various varieties of loop macro keyword ... (defvar cl-indent-body-introducing-loop-macro-keyword - "do\\|finally\\|initially" + "do\\|finally\\|initially\\|doing\\|collect\\|collecting\\|append\\|appending" "Regexp matching loop macro keywords which introduce body-forms") ;; This is so "and when" and "else when" get handled right @@ -788,7 +850,7 @@ ;; This is handled right, but it's incomplete ... ;; (It could probably get arbitrarily long if I did *every* iteration-path) (defvar cl-indent-indented-loop-macro-keyword - "into\\|by\\|upto\\|downto\\|above\\|below\\|on\\|being\\|=\\|first\\|then\\|from\\|to" + "into\\|by\\|upto\\|downto\\|above\\|below\\|on\\|in\\|being\\|=\\|first\\|then\\|from\\|to" "Regexp matching keywords introducing loop subclauses. Always indented two") (defvar cl-indent-indenting-loop-macro-keyword @@ -919,8 +981,13 @@ (defun cl-indent-loop-advance-past-keyword-on-line () (forward-word 1) - (while (and (looking-at "\\s-") (not (eolp))) - (forward-char 1)) + (block move-forward + (while (and (looking-at "\\s-") (not (eolp))) + (forward-char 1) + (when (looking-at "\\s<") + ;; eat up the comment (sorry, this will fail for for lisp block comments + (while (and (not (looking-at "\\s>")) (not (eolp))) + (forward-char 1))))) (if (eolp) nil (current-column))) @@ -962,19 +1029,18 @@ ;;; issue specifications for Common Lisp forms ;;; - (mapcar #'define-cl-indent '((block 1) (case (4 &rest (&whole 2 &rest 3))) (ccase . case) (ecase . case) (typecase . case) (etypecase . case) (ctypecase . case) (handler-bind . let) - (handler-case (4 (&whole 2 1 &rest 1))) + (handler-case (4 &rest (&whole 2 4 &rest 2))) (catch 1) - (cond (&rest (&whole 2 1 &rest 1))) + (cond cl-indent:indent-cond) (defvar (4 2 2)) (defconstant . defvar) (defparameter . defvar) - (defclass (6 6 (&whole 4 &rest (&whole 1 &rest 2)) &rest 2)) + (defclass (6 6 (&whole 2 &rest 1) &rest 2)) (define-modify-macro (4 &body)) (defsetf (4 (&whole 4 &rest 1) 4 &body)) @@ -990,6 +1056,9 @@ (&whole 4 &rest 3) ; result: ((condition) (form) ...) &rest cl-indent:indent-do)) (do* . do) + (do-all-symbols (4 &body)) + (do-symbols (4 &body)) + (do-external-symbols (4 &body)) (dolist ((&whole 4 2 1) &body)) (dotimes . dolist) (eval-when 1) @@ -1021,6 +1090,7 @@ (prog2 2) (progn 0) (progv (4 4 &body)) + (restart-case . handler-case) (return 0) (return-from (nil &body)) (tagbody cl-indent:indent-tagbody) @@ -1030,10 +1100,16 @@ (5 &body)) (values 0) (when 1) - ;; ITA additions as per /trunk/qres/lisp/LISP-STANDARDS.rest, with suggestions by scott mckay. - (make-condition (&rest 2)) - (make-instance (&rest 2)) - (with-prefixed-accessors . multiple-value-bind))) + (with-accessors (6 4 &body)) + (with-compilation-unit (4 &body)) + (with-hash-table-iterator (4 &body)) + (with-output-to-string (4 &body)) + (with-input-from-string . with-output-to-string) + (with-open-file (4 &body)) + (with-open-stream . with-open-file) + (with-package-iterator (4 &body)) + (with-simple-restart (4 &body)) + (with-slots (6 4 &body)))) ;; OK, we're almost finished. ;; --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/04/14 11:36:17 1.104 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/04/14 21:31:20 1.105 @@ -1,3 +1,19 @@ +2008-04-15 Marco Baringer + + * slime-indentation.el (cl-indent::line-number): new function. + (cl-indent:indent-cond): Custom indentation method for cl:cond. + (cl-indent-body-introducing-loop-macro-keyword) + (cl-indent-indented-loop-macro-keyword): more loop keywords. + (cl-indent-loop-advance-past-keyword-on-line): deal with comments + after loop keywords. + (#'define-cl-indent): Fix indentation of handler-case; give cond + it's custom indentation method; change indentation of defclass; + add methods for do-all-symbols, do-symbols, do-external-symbols, + restart-case, with-accessors, with-compilation-unit, + with-hash-table-iterator, with-output-to-string, + with-input-from-string, with-open-file, with-open-stream, + with-package-iterator, with-simple-restart, with-slots. + 2008-04-14 Marco Baringer * swank-arglists.lisp (decode-arglist): Arglists can be dotted From heller at common-lisp.net Thu Apr 17 14:19:14 2008 From: heller at common-lisp.net (heller) Date: Thu, 17 Apr 2008 10:19:14 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080417141914.83E4421097@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10660 Modified Files: slime.el Log Message: * slime.el (slime-set-default-directory): Send absolute filenames. --- /project/slime/cvsroot/slime/slime.el 2008/04/06 09:58:17 1.936 +++ /project/slime/cvsroot/slime/slime.el 2008/04/17 14:19:14 1.937 @@ -6274,12 +6274,13 @@ (defun slime-set-default-directory (directory) "Make DIRECTORY become Lisp's current directory." (interactive (list (read-directory-name "Directory: " nil nil t))) - (message "default-directory: %s" - (slime-from-lisp-filename - (slime-eval `(swank:set-default-directory - ,(slime-to-lisp-filename directory))))) - (with-current-buffer (slime-output-buffer) - (setq default-directory (expand-file-name directory)))) + (let ((dir (expand-file-name directory))) + (message "default-directory: %s" + (slime-from-lisp-filename + (slime-eval `(swank:set-default-directory + ,(slime-to-lisp-filename dir))))) + (with-current-buffer (slime-output-buffer) + (setq default-directory dir)))) (defun slime-sync-package-and-default-directory () "Set Lisp's package and directory to the values in current buffer." From heller at common-lisp.net Thu Apr 17 14:19:16 2008 From: heller at common-lisp.net (heller) Date: Thu, 17 Apr 2008 10:19:16 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080417141916.E7F883001C@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv10678/contrib Modified Files: swank-kawa.scm Log Message: * swank-kawa.scm (read-chunk): Call in:read in a loop. --- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/04/01 12:10:21 1.6 +++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/04/17 14:19:16 1.7 @@ -34,7 +34,7 @@ ;;;; Module declaration -;; (module-export start-swank create-swank-server swank-java-source-path) +(module-export start-swank create-swank-server swank-java-source-path) (module-static #t) @@ -465,10 +465,12 @@ (%read port rt))))) (df read-chunk ((in ) (len ) => ) - (let* ((chars ( :length len)) - (count (! read in chars))) - (assert (= count len) "count: ~d len: ~d" count len) - ( chars))) + (let ((chars ( :length len))) + (let loop ((offset :: 0)) + (cond ((= offset len) ( chars)) + (#t (let ((count (! read in chars offset (- len offset)))) + (assert (not (= count -1)) "partial packet") + (loop (+ offset count)))))))) ;;; FIXME: not thread safe (df %read ((port ) (table )) @@ -1270,10 +1272,7 @@ (set (@ names (this)) names) (set (@ values (this)) values)) ((toString) :: - (format "#" - (src-loc>str loc) - (mapi args (fun (a) - (ignore-errors (vm-demirror *the-vm* a))))))) + (format "#" (src-loc>str loc)))) (df copy-stack ((t )) (packing (pack) From heller at common-lisp.net Thu Apr 17 14:19:23 2008 From: heller at common-lisp.net (heller) Date: Thu, 17 Apr 2008 10:19:23 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080417141923.0B1DD37014@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv10707 Modified Files: ChangeLog Log Message: add changelog entry. --- /project/slime/cvsroot/slime/ChangeLog 2008/04/06 09:58:40 1.1342 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/17 14:19:22 1.1343 @@ -1,3 +1,7 @@ +2008-04-17 Helmut Eller + + * slime.el (slime-set-default-directory): Send absolute filenames. + 2008-04-06 Tobias C. Rittweiler * slime.el (slime-edit-definition): The `slime-edit-definition-hooks' From heller at common-lisp.net Thu Apr 17 14:56:45 2008 From: heller at common-lisp.net (heller) Date: Thu, 17 Apr 2008 10:56:45 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080417145645.2599064049@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17385 Modified Files: ChangeLog slime.el swank-abcl.lisp swank-allegro.lisp swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-corman.lisp swank-ecl.lisp swank-lispworks.lisp swank-openmcl.lisp swank-sbcl.lisp swank-scl.lisp swank.lisp Log Message: C-c C-c with prefix args now uses the maximal debug level. (By Zach Beane.) Only implemented for SBCL. * slime.el (slime-compile-with-maximum-debug): New variable. (slime-compile-defun, slime-compile-region): Use it. * swank.lisp (compile-string-for-emacs): Accept new debug argument. Update backend accordingly. --- /project/slime/cvsroot/slime/ChangeLog 2008/04/17 14:19:22 1.1343 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/17 14:56:43 1.1344 @@ -1,3 +1,14 @@ +2008-04-17 Zach Beane + + C-c C-c with prefix args now uses the maximal debug level. + Only implemented for SBCL. + + * slime.el (slime-compile-with-maximum-debug): New variable. + (slime-compile-defun, slime-compile-region): Use it. + + * swank.lisp (compile-string-for-emacs): Accept new debug + argument. Update backend accordingly. + 2008-04-17 Helmut Eller * slime.el (slime-set-default-directory): Send absolute filenames. --- /project/slime/cvsroot/slime/slime.el 2008/04/17 14:19:14 1.937 +++ /project/slime/cvsroot/slime/slime.el 2008/04/17 14:56:43 1.938 @@ -3721,6 +3721,9 @@ ;;;; Compilation and the creation of compiler-note annotations +(defvar slime-compile-with-maximum-debug nil + "When non-nil compile defuns with maximum debug optimization.") + (defvar slime-highlight-compiler-notes t "*When non-nil annotate buffers with compilation notes etc.") @@ -3781,10 +3784,11 @@ (slime-rcurry #'slime-compilation-finished (current-buffer))) (message "Compiling %s..." file))) -(defun slime-compile-defun () +(defun slime-compile-defun (&optional maximum-debug-p) "Compile the current toplevel form." - (interactive) - (apply #'slime-compile-region (slime-region-for-defun-at-point))) + (interactive "P") + (let ((slime-compile-with-maximum-debug maximum-debug-p)) + (apply #'slime-compile-region (slime-region-for-defun-at-point)))) (defun slime-compile-region (start end) "Compile the region." @@ -3804,7 +3808,8 @@ ,string ,(buffer-name) ,start-offset - ,(if (buffer-file-name) (file-name-directory (buffer-file-name)))) + ,(if (buffer-file-name) (file-name-directory (buffer-file-name))) + ',slime-compile-with-maximum-debug) (slime-make-compilation-finished-continuation (current-buffer)))) (defun slime-note-count-string (severity count &optional suppress-if-zero) --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/22 14:38:39 1.48 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/04/17 14:56:43 1.49 @@ -341,8 +341,9 @@ (when (and load-p (not fail)) (load fn))))))) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (let ((jvm::*resignal-compiler-warnings* t) (*abcl-signaled-conditions* nil)) (handler-bind ((warning #'handle-compiler-warning)) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/09 18:47:05 1.101 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/04/17 14:56:43 1.102 @@ -314,7 +314,9 @@ (when binary-filename (delete-file binary-filename)))))) -(defimplementation swank-compile-string (string &key buffer position directory) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore debug)) ;; We store the source buffer in excl::*source-pathname* as a string ;; of the form ;. Quite ugly encoding, but ;; the fasl file is corrupted if we use some other datatype. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/28 19:44:29 1.130 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/04/17 14:56:43 1.131 @@ -333,7 +333,7 @@ (declare (ignore ignore)) `(call-with-compilation-hooks (lambda () (progn , at body)))) -(definterface swank-compile-string (string &key buffer position directory) +(definterface swank-compile-string (string &key buffer position directory debug) "Compile source from STRING. During compilation, compiler conditions must be trapped and resignalled as COMPILER-CONDITIONs. @@ -344,7 +344,11 @@ If DIRECTORY is specified it may be used by certain implementations to rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of -source information.") +source information. + +If DEBUG is supplied, it may be used by certain implementations to +compile with maximum debugging information. +") (definterface swank-compile-file (filename load-p external-format) "Compile FILENAME signalling COMPILE-CONDITIONs. --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/22 14:11:52 1.68 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/04/17 14:56:43 1.69 @@ -573,8 +573,9 @@ (load fasl-file)) nil)))) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-offset* position)) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/09 18:47:05 1.178 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/04/17 14:56:43 1.179 @@ -347,8 +347,9 @@ (when load-p (load output-file))) (values output-file warnings-p failure-p))))) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-start-position* position) --- /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/09 18:47:05 1.15 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/04/17 14:56:43 1.16 @@ -373,8 +373,9 @@ (when load-p (load (compile-file-pathname *compile-filename*)))))) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-position* position) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/03/19 02:34:30 1.15 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/17 14:56:43 1.16 @@ -131,8 +131,9 @@ (compile-file *compile-filename*) (when load-p (unless fail (load fn))))))) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-start-position* position) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/03/27 21:59:45 1.98 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/04/17 14:56:43 1.99 @@ -558,8 +558,9 @@ nil))) htab)) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (assert buffer) (assert position) (let* ((location (list :emacs-buffer buffer position string)) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/09 18:47:05 1.124 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/04/17 14:56:43 1.125 @@ -426,8 +426,9 @@ (mapcan 'who-specializes (ccl::%class-direct-subclasses class))) :test 'equal)) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-offset* position) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/03/26 15:57:37 1.194 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/04/17 14:56:43 1.195 @@ -442,11 +442,15 @@ "Return a temporary file name to compile strings into." (concatenate 'string (tmpnam nil) ".lisp")) -(defimplementation swank-compile-string (string &key buffer position directory) +(defimplementation swank-compile-string (string &key buffer position directory + debug) (let ((*buffer-name* buffer) (*buffer-offset* position) (*buffer-substring* string) - (filename (temp-file-name))) + (filename (temp-file-name)) + (old-min-debug (assoc 'debug (sb-ext:restrict-compiler-policy)))) + (when debug + (sb-ext:restrict-compiler-policy 'debug 3)) (flet ((compile-it (fn) (with-compilation-hooks () (with-compilation-unit @@ -462,6 +466,7 @@ (compile-it #'load) (load (compile-it #'identity))) (ignore-errors + (sb-ext:restrict-compiler-policy 'debug (or old-min-debug 0)) (delete-file filename) (delete-file (compile-file-pathname filename))))))) --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/10 08:32:04 1.18 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/04/17 14:56:43 1.19 @@ -391,8 +391,9 @@ (when load-p (load output-file))) (values output-file warnings-p failure-p))))) -(defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) +(defimplementation swank-compile-string (string &key buffer position directory + debug) + (declare (ignore directory debug)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-start-position* position) --- /project/slime/cvsroot/slime/swank.lisp 2008/03/27 11:46:50 1.542 +++ /project/slime/cvsroot/slime/swank.lisp 2008/04/17 14:56:43 1.543 @@ -2230,7 +2230,7 @@ (or (guess-external-format filename) :default))))))) -(defslimefun compile-string-for-emacs (string buffer position directory) +(defslimefun compile-string-for-emacs (string buffer position directory debug) "Compile STRING (exerpted from BUFFER at POSITION). Record compiler notes signalled as `compiler-condition's." (with-buffer-syntax () @@ -2238,7 +2238,8 @@ (lambda () (let ((*compile-print* nil) (*compile-verbose* t)) (swank-compile-string string :buffer buffer :position position - :directory directory)))))) + :directory directory + :debug debug)))))) (defun file-newer-p (new-file old-file) "Returns true if NEW-FILE is newer than OLD-FILE." From heller at common-lisp.net Thu Apr 17 15:21:51 2008 From: heller at common-lisp.net (heller) Date: Thu, 17 Apr 2008 11:21:51 -0400 (EDT) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080417152151.75C7742030@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv24228/contrib Modified Files: ChangeLog swank-fancy-inspector.lisp Log Message: Use slime-read-from-minibuffer instead of slime-read-object. * swank-fancy-inspector.lisp (inspect-slot-for-emacs): slime-read-object has been gone for a long time, replaced with slime-read-from-minibuffer. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/04/14 21:31:20 1.105 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/04/17 15:21:51 1.106 @@ -1,3 +1,9 @@ +2008-04-17 G?bor Melis + + * swank-fancy-inspector.lisp (inspect-slot-for-emacs): + slime-read-object has been gone for a long time, replaced with + slime-read-from-minibuffer. + 2008-04-15 Marco Baringer * slime-indentation.el (cl-indent::line-number): new function. --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/03/14 14:39:20 1.14 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/04/17 15:21:51 1.15 @@ -175,7 +175,7 @@ (abort "Abort setting slot ~S" slot-name) (let ((value-string (eval-in-emacs `(condition-case c - (slime-read-object + (slime-read-from-minibuffer ,(format nil "Set slot ~S to (evaluated) : " slot-name)) (quit nil))))) (when (and value-string From heller at common-lisp.net Thu Apr 17 15:21:57 2008 From: heller at common-lisp.net (heller) Date: Thu, 17 Apr 2008 11:21:57 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080417152157.E33BB46180@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv24250 Modified Files: ChangeLog swank.asd Log Message: * swank.asd: Don't make a compile-op a no-op so that a swank-loader.fasl file gets generated and (require 'swank) can be called multiple times. (Patch by Travis Cross.) --- /project/slime/cvsroot/slime/ChangeLog 2008/04/17 14:56:43 1.1344 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/17 15:21:57 1.1345 @@ -1,3 +1,9 @@ +2008-04-17 Travis Cross + + * swank.asd: Don't make a compile-op a no-op so that a + swank-loader.fasl file gets generated and (require 'swank) can be + called multiple times. + 2008-04-17 Zach Beane C-c C-c with prefix args now uses the maximal debug level. --- /project/slime/cvsroot/slime/swank.asd 2008/03/04 13:40:50 1.8 +++ /project/slime/cvsroot/slime/swank.asd 2008/04/17 15:21:57 1.9 @@ -26,17 +26,6 @@ (defclass swank-loader-file (asdf:cl-source-file) ()) -;;;; make compile-op a nop - -(defmethod asdf:output-files ((o asdf:compile-op) (f swank-loader-file)) - (list (asdf:component-pathname f))) - -(defmethod asdf:perform ((o asdf:compile-op) (f swank-loader-file)) - t) - -(defmethod asdf:operation-done-p ((o asdf:compile-op) (f swank-loader-file)) - t) - ;;;; after loading run init (defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file)) From gcarncross at common-lisp.net Thu Apr 24 01:24:14 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:24:14 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424012414.8D77E161C6@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6405 Modified Files: swank-source-file-cache.lisp Log Message: Include #\Page as whitespace --- /project/slime/cvsroot/slime/swank-source-file-cache.lisp 2006/12/05 13:00:42 1.8 +++ /project/slime/cvsroot/slime/swank-source-file-cache.lisp 2008/04/24 01:24:14 1.9 @@ -103,7 +103,7 @@ (defun skip-comments-and-whitespace (stream) (case (peek-char nil stream) - ((#\Space #\Tab #\Newline #\Linefeed) + ((#\Space #\Tab #\Newline #\Linefeed #\Page) (read-char stream) (skip-comments-and-whitespace stream)) (#\; From gcarncross at common-lisp.net Thu Apr 24 01:24:34 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:24:34 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424012434.B377F2001B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6454 Modified Files: swank-loader.lisp Log Message: Include swank-source-path-parser and swank-source-file-cache for ECL --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/03/27 11:46:41 1.84 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/04/24 01:24:34 1.85 @@ -42,7 +42,7 @@ #+clisp '(xref metering swank-clisp swank-gray) #+armedbear '(swank-abcl) #+cormanlisp '(swank-corman swank-gray) - #+ecl '(swank-ecl swank-gray)) + #+ecl '(swank-source-path-parser swank-source-file-cache swank-ecl swank-gray)) (defparameter *implementation-features* '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp From gcarncross at common-lisp.net Thu Apr 24 01:25:05 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:25:05 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424012505.D764B39171@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6500 Modified Files: swank-ecl.lisp Log Message: Initial support for find-source-location with functions --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/17 14:56:43 1.16 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/24 01:25:05 1.17 @@ -302,6 +302,22 @@ (defimplementation find-definitions (name) nil) +(defimplementation find-source-location (obj) + (or + (typecase obj + (function + (multiple-value-bind (file pos) (ignore-errors (si:bc-file obj)) + (if (and file pos) + `(:location + (:file ,file) + (:position ,pos) + (:snippet + ,(with-open-file (s file) + (skip-toplevel-forms pos s) + (skip-comments-and-whitespace s) + (read-snippet s)))))))) + `(:error (format nil "Source definition of ~S not found" obj)))) + ;;;; Threads #+threads From gcarncross at common-lisp.net Thu Apr 24 01:25:20 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:25:20 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424012520.C51C43C010@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6616 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2008/04/17 15:21:57 1.1345 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/24 01:25:20 1.1346 @@ -1,3 +1,14 @@ +2008-04-23 Geo Carncross + + * swank-source-file-cache.lisp (skip-comments-and-whitespace): + Include #\Page as whitespace + + * swank-ecl.lisp (find-source-location): Initial support for + find-source-location with functions + + * swank-loader.lisp (*sysdep-files*): Include swank-source-path-parser + and swank-source-file-cache for ECL + 2008-04-17 Travis Cross * swank.asd: Don't make a compile-op a no-op so that a From gcarncross at common-lisp.net Thu Apr 24 01:38:29 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:38:29 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424013829.D3E9F3E056@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9057 Modified Files: swank-ecl.lisp Log Message: fixup flushing and location create --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/24 01:25:05 1.17 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/24 01:38:29 1.18 @@ -308,14 +308,14 @@ (function (multiple-value-bind (file pos) (ignore-errors (si:bc-file obj)) (if (and file pos) - `(:location - (:file ,file) - (:position ,pos) - (:snippet - ,(with-open-file (s file) - (skip-toplevel-forms pos s) - (skip-comments-and-whitespace s) - (read-snippet s)))))))) + (make-location + `(:file ,file) + `(:position ,pos) + `(:snippet + ,(with-open-file (s file) + (skip-toplevel-forms pos s) + (skip-comments-and-whitespace s) + (read-snippet s)))))))) `(:error (format nil "Source definition of ~S not found" obj)))) ;;;; Threads @@ -469,7 +469,9 @@ (not (and (open-stream-p x) (output-stream-p x)))) *auto-flush-streams*)) - (mapc #'stream-finish-output *auto-flush-streams*))) + (dolist (i *auto-flush-streams*) + (ignore-errors (stream-finish-output i)) + (ignore-errors (finish-output i))))) (sleep *auto-flush-interval*))) ) From gcarncross at common-lisp.net Thu Apr 24 01:39:09 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:39:09 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424013909.9805E3E056@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9147 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2008/04/24 01:25:20 1.1346 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/24 01:39:09 1.1347 @@ -5,10 +5,12 @@ * swank-ecl.lisp (find-source-location): Initial support for find-source-location with functions + (flush-streams): Workaround differences in different ECL versions * swank-loader.lisp (*sysdep-files*): Include swank-source-path-parser and swank-source-file-cache for ECL + 2008-04-17 Travis Cross * swank.asd: Don't make a compile-op a no-op so that a From gcarncross at common-lisp.net Thu Apr 24 01:44:10 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:44:10 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424014410.ED4CA47001@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11824 Modified Files: swank-ecl.lisp Log Message: basic/simple implementation of find-definitions --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/24 01:38:29 1.18 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/24 01:44:10 1.19 @@ -10,6 +10,8 @@ (in-package :swank-backend) +(defvar *tmp*) + (if (find-package :gray) (import-from :gray *gray-stream-symbols* :swank-backend) (import-from :ext *gray-stream-symbols* :swank-backend)) @@ -300,16 +302,20 @@ ;;;; Definitions -(defimplementation find-definitions (name) nil) +(defimplementation find-definitions (name) + (if (fboundp name) + (let ((tmp (find-source-location (symbol-function name)))) + `(((defun ,name) ,tmp))))) (defimplementation find-source-location (obj) + (setf *tmp* obj) (or (typecase obj (function (multiple-value-bind (file pos) (ignore-errors (si:bc-file obj)) (if (and file pos) (make-location - `(:file ,file) + `(:file ,(namestring file)) `(:position ,pos) `(:snippet ,(with-open-file (s file) From gcarncross at common-lisp.net Thu Apr 24 01:44:35 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Wed, 23 Apr 2008 21:44:35 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424014435.388A94D0A2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11886 Modified Files: ChangeLog Log Message: --- /project/slime/cvsroot/slime/ChangeLog 2008/04/24 01:39:09 1.1347 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/24 01:44:35 1.1348 @@ -6,6 +6,7 @@ * swank-ecl.lisp (find-source-location): Initial support for find-source-location with functions (flush-streams): Workaround differences in different ECL versions + (find-definitions): basic/simple implementation of find-definitions * swank-loader.lisp (*sysdep-files*): Include swank-source-path-parser and swank-source-file-cache for ECL From trittweiler at common-lisp.net Thu Apr 24 18:51:04 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 24 Apr 2008 14:51:04 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424185104.0935C3307E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11154 Modified Files: swank-backend.lisp Log Message: * swank-backend.lisp: Clarified docstrings of interface functions in the Debugging section. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/04/17 14:56:43 1.131 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/04/24 18:51:03 1.132 @@ -612,16 +612,6 @@ user without (re)entering the debugger by wrapping them as `sldb-condition's.")) -(definterface compute-backtrace (start end) - "Return a list containing a backtrace of the condition current -being debugged. The results are unspecified if this function is -called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT. - -START and END are zero-based indices constraining the number of frames -returned. Frame zero is defined as the frame which invoked the -debugger. If END is nil, return the frames from START to the end of -the stack.") - (definterface compute-sane-restarts (condition) "This is an opportunity for Lisps such as CLISP to remove unwanted restarts from the output of CL:COMPUTE-RESTARTS, @@ -629,28 +619,48 @@ what the default implementation does." (compute-restarts condition)) +;;; The following functions in this section are supposed to be called +;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. + +(definterface compute-backtrace (start end) + "Returns a backtrace of the condition currently being debugged, +that is an ordered list consisting of frames. (What constitutes a +frame is implementation dependent, but PRINT-FRAME must be defined on +it.) + +``Ordered list'' means that the i-th. frame is associated to the +frame-number i. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + (definterface print-frame (frame stream) "Print frame to stream.") (definterface frame-source-location-for-emacs (frame-number) - "Return the source location for FRAME-NUMBER.") + "Return the source location for the frame associated to FRAME-NUMBER.") (definterface frame-catch-tags (frame-number) - "Return a list of XXX list of what? catch tags for a debugger -stack frame. The results are undefined unless this is called -within the dynamic contour of a function defined by -DEFINE-DEBUGGER-HOOK.") + "Return a list of catch tags for being printed in a debugger stack +frame.") (definterface frame-locals (frame-number) - "Return a list of XXX local variable designators define me -for a debugger stack frame. The results are undefined unless -this is called within the dynamic contour of a function defined -by DEFINE-DEBUGGER-HOOK.") - -(definterface frame-var-value (frame var) - "Return the value of VAR in FRAME. -FRAME is the number of the frame in the backtrace. -VAR is the number of the variable in the frame.") + "Return a list of ((&key NAME ID VALUE) ...) where each element of +the list represents a local variable in the stack frame associated to +FRAME-NUMBER. + +NAME, a symbol; the name of the local variable. + +ID, an integer; used as primary key for the local variable, unique +relatively to the frame under operation. + +value, an object; the value of the local variable.") + +(definterface frame-var-value (frame-number var-id) + "Return the value of the local variable associated to VAR-ID +relatively to the frame associated to FRAME-NUMBER.") (definterface disassemble-frame (frame-number) "Disassemble the code for the FRAME-NUMBER. @@ -659,8 +669,7 @@ (definterface eval-in-frame (form frame-number) "Evaluate a Lisp form in the lexical context of a stack frame -in the debugger. The results are undefined unless called in the -dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK. +in the debugger. FRAME-NUMBER must be a positive integer with 0 indicating the frame which invoked the debugger. From trittweiler at common-lisp.net Thu Apr 24 18:51:16 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 24 Apr 2008 14:51:16 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080424185116.459A7340C9@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11262 Modified Files: ChangeLog Log Message: * swank-backend.lisp: Clarified docstrings of interface functions in the Debugging section. --- /project/slime/cvsroot/slime/ChangeLog 2008/04/24 01:44:35 1.1348 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/24 18:51:16 1.1349 @@ -1,3 +1,8 @@ +2008-04-24 Tobias C. Rittweiler + + * swank-backend.lisp: Clarified docstrings of interface functions + in the Debugging section. + 2008-04-23 Geo Carncross * swank-source-file-cache.lisp (skip-comments-and-whitespace): From gcarncross at common-lisp.net Wed Apr 30 02:10:49 2008 From: gcarncross at common-lisp.net (gcarncross) Date: Tue, 29 Apr 2008 22:10:49 -0400 (EDT) Subject: [slime-cvs] CVS slime Message-ID: <20080430021049.051AB1B032@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv12042 Modified Files: ChangeLog swank-ecl.lisp Log Message: Backtrace and frame/eval improvements --- /project/slime/cvsroot/slime/ChangeLog 2008/04/24 18:51:16 1.1349 +++ /project/slime/cvsroot/slime/ChangeLog 2008/04/30 02:10:49 1.1350 @@ -1,3 +1,7 @@ +2008-04-29 Geo Carncross + + * swank-ecl.lisp: Backtrace and frame/eval improvements + 2008-04-24 Tobias C. Rittweiler * swank-backend.lisp: Clarified docstrings of interface functions --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/24 01:44:10 1.19 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/04/30 02:10:49 1.20 @@ -207,7 +207,8 @@ ;;; Debugging (import - '(si::*ihs-top* + '(si::*break-env* + si::*ihs-top* si::*ihs-current* si::*ihs-base* si::*frs-base* @@ -216,11 +217,15 @@ si::*tpl-level* si::frs-top si::ihs-top + si::ihs-fun + si::ihs-env si::sch-frs-base si::set-break-env si::set-current-ihs si::tpl-commands)) +(defvar *backtrace* '()) + (defimplementation call-with-debugging-environment (debugger-loop-fn) (declare (type function debugger-loop-fn)) (let* ((*tpl-commands* si::tpl-commands) @@ -229,27 +234,97 @@ (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*read-suppress* nil) - (*tpl-level* (1+ *tpl-level*))) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from *ihs-base* below *ihs-top* + collect (list (si::ihs-fun (1+ ihs)) + (si::ihs-env ihs) + nil)))) + (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (fixnump name) + (push name (third x))))))) + (setf *backtrace* (nreverse *backtrace*)) (set-break-env) (set-current-ihs) - (funcall debugger-loop-fn))) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (*ihs-base*(si::ihs-top 'call-with-debugger-hook))) + (funcall fun))) -;; (defimplementation call-with-debugger-hook (hook fun) -;; (let ((*debugger-hook* hook)) -;; (funcall fun))) - -(defun nth-frame (n) - (cond ((>= n *ihs-top* ) nil) - (t (- *ihs-top* n)))) - (defimplementation compute-backtrace (start end) - (loop for i from start below end - for f = (nth-frame i) - while f - collect f)) + (when (numberp end) + (setf end (min end (length *backtrace*)))) + (subseq *backtrace* start end)) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::bc-file fun) + (and file (make-location `(:file ,file) `(:position ,position))))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (dolist (record (second frame)) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((symbolp record0) + (setq variables (acons record0 record1 variables))) + ((not (fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) (defimplementation print-frame (frame stream) - (format stream "~A" (si::ihs-fname frame))) + (format stream "~A" (first frame))) + +(defimplementation frame-source-location-for-emacs (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + with i = 0 + collect (list :name name :id (prog1 i (incf i)) :value value))) + +(defimplementation frame-var-value (frame-number var-id) + (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + var-id)) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-fun (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-with-env form env))) ;;;; Inspector @@ -312,7 +387,7 @@ (or (typecase obj (function - (multiple-value-bind (file pos) (ignore-errors (si:bc-file obj)) + (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj)) (if (and file pos) (make-location `(:file ,(namestring file))