From heller at common-lisp.net Sat Oct 11 08:20:24 2008 From: heller at common-lisp.net (CVS User heller) Date: Sat, 11 Oct 2008 08:20:24 +0000 Subject: [slime-cvs] CVS CVSROOT Message-ID: Update of /project/slime/cvsroot/CVSROOT In directory cl-net:/tmp/cvs-serv3627 Modified Files: loginfo Log Message: use our private copy of cvs-mailcommit in /project/slime/bin. --- /project/slime/cvsroot/CVSROOT/loginfo 2008/08/08 18:20:46 1.9 +++ /project/slime/cvsroot/CVSROOT/loginfo 2008/10/11 08:20:24 1.10 @@ -28,5 +28,5 @@ #DEFAULT /custom/bin/cvslog.py slime-cvs at common-lisp.net %{sVv} #DEFAULT /project/slime/bin/cvslog.sh slime-cvs at common-lisp.net slime-devel at common-lisp.net -DEFAULT cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} +DEFAULT /project/slime/bin/cvs-mailcommit --mailto slime-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} #ALL /home/heller/bin/convert-to-hg.sh From heller at common-lisp.net Sat Oct 11 08:30:43 2008 From: heller at common-lisp.net (CVS User heller) Date: Sat, 11 Oct 2008 08:30:43 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5374 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (list-callers): Do a full GC before calling map-allocated-objects. That's needed because map-allocated-objects seems to cons even if it's inlined. (emacs-inspect [code-component]): Try to detect byte-code-components. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/10 06:09:32 1.1553 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/11 08:30:43 1.1554 @@ -14,6 +14,14 @@ * swank.lisp (*backtrace-printer-bindings*): export. +2008-10-05 Helmut Eller + + * swank-cmucl.lisp (list-callers): Do a full GC before calling + map-allocated-objects. That's needed because map-allocated-objects + seems to cons even if it's inlined. + (emacs-inspect [code-component]): Try to detect + byte-code-components. + 2008-10-04 Tobias C. Rittweiler * swank-sbcl.lisp: Add support for WHO-SPECIALIZES. This requires --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/04 19:13:41 1.197 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/11 08:30:43 1.198 @@ -584,113 +584,87 @@ ;;; strategy would be to use the disassembler to find actual ;;; call-sites. -(declaim (inline map-code-constants)) -(defun map-code-constants (code fn) - "Call FN for each constant in CODE's constant pool." - (check-type code kernel:code-component) - (loop for i from vm:code-constants-offset below (kernel:get-header-data code) - do (funcall fn (kernel:code-header-ref code i)))) - -(defun function-callees (function) - "Return FUNCTION's callees as a list of functions." - (let ((callees '())) - (map-code-constants - (vm::find-code-object function) - (lambda (obj) - (when (kernel:fdefn-p obj) - (push (kernel:fdefn-function obj) callees)))) - callees)) - -(declaim (ext:maybe-inline map-allocated-code-components)) -(defun map-allocated-code-components (spaces fn) - "Call FN for each allocated code component in one of SPACES. FN -receives the object as argument. SPACES should be a list of the -symbols :dynamic, :static, or :read-only." - (dolist (space spaces) - (declare (inline vm::map-allocated-objects) - (optimize (ext:inhibit-warnings 3))) - (vm::map-allocated-objects - (lambda (obj header size) - (declare (type fixnum size) (ignore size)) - (when (= vm:code-header-type header) - (funcall fn obj))) - space))) - -(declaim (ext:maybe-inline map-caller-code-components)) -(defun map-caller-code-components (function spaces fn) - "Call FN for each code component with a fdefn for FUNCTION in its -constant pool." - (let ((function (coerce function 'function))) - (declare (inline map-allocated-code-components)) - (map-allocated-code-components - spaces - (lambda (obj) - (map-code-constants - obj - (lambda (constant) - (when (and (kernel:fdefn-p constant) - (eq (kernel:fdefn-function constant) - function)) - (funcall fn obj)))))))) - -(defun function-callers (function &optional (spaces '(:read-only :static - :dynamic))) - "Return FUNCTION's callers. The result is a list of code-objects." - (let ((referrers '())) - (declare (inline map-caller-code-components)) - ;;(ext:gc :full t) - (map-caller-code-components function spaces - (lambda (code) (push code referrers))) - referrers)) - -(defun debug-info-definitions (debug-info) - "Return the defintions for a debug-info. This should only be used -for code-object without entry points, i.e., byte compiled -code (are theree others?)" - ;; This mess has only been tested with #'ext::skip-whitespace, a - ;; byte-compiled caller of #'read-char . - (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) - (let ((name (c::debug-info-name debug-info)) - (source (c::debug-info-source debug-info))) - (destructuring-bind (first) source - (ecase (c::debug-source-from first) - (:file - (list (list name - (make-location - (list :file (unix-truename (c::debug-source-name first))) - (list :function-name (string name)))))))))) - -(defun code-component-entry-points (code) - "Return a list ((NAME LOCATION) ...) of function definitons for -the code omponent CODE." - (let ((names '())) - (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) - ((not f)) - (let ((name (kernel:%function-name f))) - (when (ext:valid-function-name-p name) - (push (list name (function-location f)) names)))) - names)) - -(defimplementation list-callers (symbol) - "Return a list ((NAME LOCATION) ...) of callers." - (let ((components (function-callers symbol)) - (xrefs '())) - (dolist (code components) - (let* ((entry (kernel:%code-entry-points code)) - (defs (if entry - (code-component-entry-points code) - ;; byte compiled stuff - (debug-info-definitions - (kernel:%code-debug-info code))))) - (setq xrefs (nconc defs xrefs)))) - xrefs)) - -(defimplementation list-callees (symbol) - (let ((fns (function-callees symbol))) - (mapcar (lambda (fn) - (list (kernel:%function-name fn) - (function-location fn))) - fns))) +(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t)) + (map-cpool (code fun) + (declare (type kernel:code-component code) (type function fun)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data code) + do (funcall fun (kernel:code-header-ref code i)))) + + (callees (fun) + (let ((callees (make-stack))) + (map-cpool (vm::find-code-object fun) + (lambda (o) + (when (kernel:fdefn-p o) + (vector-push-extend (kernel:fdefn-function o) + callees)))) + (coerce callees 'list))) + + (callers (fun) + (declare (function fun)) + (let ((callers (make-stack))) + (ext:gc :full t) + ;; scan :dynamic first to avoid the need for even more gcing + (dolist (space '(:dynamic :read-only :static)) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum header) (ignore size)) + (when (= vm:code-header-type header) + (map-cpool obj + (lambda (c) + (when (and (kernel:fdefn-p c) + (eq (kernel:fdefn-function c) fun)) + (vector-push-extend obj callers)))))) + space) + (ext:gc)) + (coerce callers 'list))) + + (entry-points (code) + (loop for entry = (kernel:%code-entry-points code) + then (kernel::%function-next entry) + while entry + collect entry)) + + (guess-main-entry-point (entry-points) + (or (find-if (lambda (fun) + (ext:valid-function-name-p + (kernel:%function-name fun))) + entry-points) + (car entry-points))) + + (fun-dspec (fun) + (list (kernel:%function-name fun) (function-location fun))) + + (code-dspec (code) + (let ((eps (entry-points code)) + (di (kernel:%code-debug-info code))) + (cond (eps (fun-dspec (guess-main-entry-point eps))) + (di (list (c::debug-info-name di) + (debug-info-function-name-location di))) + (t (list (princ-to-string code) + `(:error "No src-loc available"))))))) + (declare (inline map-cpool)) + + (defimplementation list-callers (symbol) + (mapcar #'code-dspec (callers (coerce symbol 'function) ))) + + (defimplementation list-callees (symbol) + (mapcar #'fun-dspec (callees symbol)))) + +(defun test-list-callers (count) + (let ((funsyms '())) + (do-all-symbols (s) + (when (and (fboundp s) + (functionp (symbol-function s)) + (not (macro-function s)) + (not (special-operator-p s))) + (push s funsyms))) + (let ((len (length funsyms))) + (dotimes (i count) + (let ((sym (nth (random len) funsyms))) + (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym)))))))) + +;; (test-list-callers 100) ;;;; Resolving source locations @@ -1960,8 +1934,11 @@ append (label-value-line i (kernel:code-header-ref o i))) `("Code:" (:newline) , (with-output-to-string (s) - (cond ((kernel:%code-debug-info o) + (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) (disassem:disassemble-code-component o :stream s)) + ((c::debug-info-p (kernel:%code-debug-info o)) + (let ((*standard-output* s)) + (c:disassem-byte-component o))) (t (disassem:disassemble-memory (disassem::align From heller at common-lisp.net Sat Oct 11 08:30:52 2008 From: heller at common-lisp.net (CVS User heller) Date: Sat, 11 Oct 2008 08:30:52 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5420 Modified Files: ChangeLog swank-cmucl.lisp Log Message: * swank-cmucl.lisp (inspect-alien-record, mv-function-end-breakpoint-values): Avoid compiler warnigns. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/11 08:30:43 1.1554 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/11 08:30:52 1.1555 @@ -22,6 +22,9 @@ (emacs-inspect [code-component]): Try to detect byte-code-components. + (inspect-alien-record, mv-function-end-breakpoint-values): Avoid + compiler warnigns. + 2008-10-04 Tobias C. Rittweiler * swank-sbcl.lisp: Add support for WHO-SPECIALIZES. This requires --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/11 08:30:43 1.198 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/11 08:30:52 1.199 @@ -1682,7 +1682,7 @@ (defun breakpoint-values (breakpoint) "Return the list of return values for a return point." (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) - (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (let ((sc (locally (declare (optimize (speed 0))) (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) (cl (di:breakpoint-what breakpoint))) (ecase (di:code-location-kind cl) @@ -1706,7 +1706,7 @@ (defun mv-function-end-breakpoint-values (sigcontext) (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) (cond (sym (funcall sym sigcontext)) - (t (di::get-function-end-breakpoint-values sigcontext))))) + (t (funcall 'di::get-function-end-breakpoint-values sigcontext))))) (defun debug-function-returns (debug-fun) "Return the return style of DEBUG-FUN." @@ -1990,6 +1990,7 @@ (:name name)) (loop for field in fields append (let ((slot (alien::alien-record-field-name field))) + (declare (optimize (speed 0))) (label-value-line slot (alien:slot alien slot)))))))) (defun inspect-alien-pointer (alien) From heller at common-lisp.net Sat Oct 11 08:30:57 2008 From: heller at common-lisp.net (CVS User heller) Date: Sat, 11 Oct 2008 08:30:57 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv5463 Modified Files: swank-cmucl.lisp Log Message: (emacs-inspect [code-component]): Detect another byte-code case. --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/11 08:30:52 1.199 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/11 08:30:57 1.200 @@ -1932,22 +1932,24 @@ (loop for i from vm:code-constants-offset below (kernel:get-header-data o) append (label-value-line i (kernel:code-header-ref o i))) - `("Code:" (:newline) - , (with-output-to-string (s) - (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) - (disassem:disassemble-code-component o :stream s)) - ((c::debug-info-p (kernel:%code-debug-info o)) - (let ((*standard-output* s)) - (c:disassem-byte-component o))) - (t - (disassem:disassemble-memory - (disassem::align - (+ (logandc2 (kernel:get-lisp-obj-address o) - vm:lowtag-mask) - (* vm:code-constants-offset vm:word-bytes)) - (ash 1 vm:lowtag-bits)) - (ash (kernel:%code-code-size o) vm:word-shift) - :stream s))))))) + `("Code:" + (:newline) + , (with-output-to-string (*standard-output*) + (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) + (disassem:disassemble-code-component o)) + ((or + (c::debug-info-p (kernel:%code-debug-info o)) + (consp (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + (c:disassem-byte-component o)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift)))))))) (defmethod emacs-inspect ((o kernel:fdefn)) (label-value-line* From nsiivola at common-lisp.net Sat Oct 11 17:13:18 2008 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Sat, 11 Oct 2008 17:13:18 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv29635/contrib Modified Files: ChangeLog slime-scratch.el Log Message: persistent scratch buffer Setting slime-sratch-file make slime-scratch use that file to back the scratch buffer, making it persistent. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/09/13 10:39:02 1.130 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/11 17:13:18 1.131 @@ -1,3 +1,10 @@ +2008-10-11 Nikodemus Siivola + + * slime-scratch.el (slime-scratch-file): New variable. + (slime-scratch-buffer): If *slime-scratch* does not exist and + slime-scratch-file is set, use 'find-file' instead of + `get-buffer-create' to obtain the buffer. + 2008-09-13 Tobias C. Rittweiler * slime-parse.el (slime-has-symbol-syntax-p): New. --- /project/slime/cvsroot/slime/contrib/slime-scratch.el 2007/09/20 14:55:53 1.4 +++ /project/slime/cvsroot/slime/contrib/slime-scratch.el 2008/10/11 17:13:18 1.5 @@ -28,10 +28,15 @@ (unless (eq (current-buffer) (window-buffer)) (pop-to-buffer (current-buffer) t))) +(defvar slime-scratch-file nil) + (defun slime-scratch-buffer () "Return the scratch buffer, create it if necessary." (or (get-buffer "*slime-scratch*") - (with-current-buffer (get-buffer-create "*slime-scratch*") + (with-current-buffer (if slime-scratch-file + (find-file slime-scratch-file) + (get-buffer-create "*slime-scratch*")) + (rename-buffer "*slime-scratch*") (lisp-mode) (use-local-map slime-scratch-mode-map) (slime-mode t) From nsiivola at common-lisp.net Sat Oct 11 17:13:19 2008 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Sat, 11 Oct 2008 17:13:19 +0000 Subject: [slime-cvs] CVS slime/doc Message-ID: Update of /project/slime/cvsroot/slime/doc In directory cl-net:/tmp/cvs-serv29635/doc Modified Files: slime.texi Log Message: persistent scratch buffer Setting slime-sratch-file make slime-scratch use that file to back the scratch buffer, making it persistent. --- /project/slime/cvsroot/slime/doc/slime.texi 2008/10/10 06:09:32 1.65 +++ /project/slime/cvsroot/slime/doc/slime.texi 2008/10/11 17:13:18 1.66 @@ -12,7 +12,7 @@ @set EDITION 3.0-alpha @set SLIMEVER 3.0-alpha @c @set UPDATED @today{} - at set UPDATED @code{$Date: 2008/10/10 06:09:32 $} + at set UPDATED @code{$Date: 2008/10/11 17:13:18 $} @set TITLE SLIME User Manual @settitle @value{TITLE}, version @value{EDITION} @@ -2739,8 +2739,10 @@ @anchor{slime-scratch} The @SLIME{} scratch buffer, in contrib package @code{slime-scratch}, -imitates Emacs' usual @code{*scratch*} buffer. It's just like any -other Lisp buffer, except for the command bound to @kbd{C-j}. +imitates Emacs' usual @code{*scratch*} buffer. +If @code{slime-scratch-file} is set, it is used to back the scratch +buffer, making it persistent. The buffer is like any other Lisp +buffer, except for the command bound to @kbd{C-j}. @table @kbd From heller at common-lisp.net Sat Oct 11 19:36:48 2008 From: heller at common-lisp.net (CVS User heller) Date: Sat, 11 Oct 2008 19:36:48 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv24765/contrib Modified Files: ChangeLog swank-kawa.scm Log Message: * swank-kawa.scm (compile-file-for-emacs, wrap-compilation) (compile-string-for-emacs): Return a :compilation-result as expected by Emacs. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/11 17:13:18 1.131 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/11 19:36:48 1.132 @@ -5,6 +5,12 @@ slime-scratch-file is set, use 'find-file' instead of `get-buffer-create' to obtain the buffer. +2008-10-11 Helmut Eller + + * swank-kawa.scm (compile-file-for-emacs, wrap-compilation) + (compile-string-for-emacs): Return a :compilation-result as + expected by Emacs. + 2008-09-13 Tobias C. Rittweiler * slime-parse.el (slime-has-symbol-syntax-p): New. --- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/04/17 14:19:16 1.7 +++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/10/11 19:36:48 1.8 @@ -629,38 +629,40 @@ ;;;; Compilation -(define-constant compilation-messages ()) - (defslimefun compile-file-for-emacs (env (filename ) load?) (let ((zip (cat (path-sans-extension (filepath filename)) ".zip"))) (wrap-compilation - (fun () (kawa.lang.CompileFile:read filename compilation-messages)) + (fun ((m )) + (kawa.lang.CompileFile:read filename m)) zip (if (lisp-bool load?) env #f) #f))) (df wrap-compilation (f zip env delete?) - (! clear compilation-messages) - (let ((start-time (current-time))) + (let ((start-time (current-time)) + (messages ())) (try-catch - (let ((c (as (f)))) + (let ((c (as (f messages)))) (! compile-to-archive c (! get-module c) zip)) (ex (log "error during compilation: ~a\n" ex) - (! error compilation-messages (as #\f) + (! error messages (as #\f) (to-str (exception-message ex)) #!null))) (log "compilation done.\n") - (when (and env - (zero? (! get-error-count compilation-messages))) - (log "loading ...\n") - (eval `(load ,zip) env) - (log "loading ... done.\n")) - (when delete? - (ignore-errors (delete-file zip))) - (let ((end-time (current-time))) - (list 'nil (format "~3f" (/ (- end-time start-time) 1000)))))) + (let ((success? (zero? (! get-error-count messages)))) + (when (and env success?) + (log "loading ...\n") + (eval `(load ,zip) env) + (log "loading ... done.\n")) + (when delete? + (ignore-errors (delete-file zip))) + (let ((end-time (current-time))) + (list ':compilation-result + (compiler-notes-for-emacs messages) + (if success? 't 'nil) + (/ (- end-time start-time) 1000.0)))))) (defslimefun compile-string-for-emacs (env string buffer offset dir) (wrap-compilation - (fun () + (fun ((m )) (let ((c (as (call-with-input-string string @@ -668,7 +670,7 @@ (! set-path p (format "~s" `(buffer ,buffer offset ,offset str ,string))) - (kawa.lang.CompileFile:read p compilation-messages)))))) + (kawa.lang.CompileFile:read p m)))))) (let ((o (@ currentOptions c))) (! set o "warn-invoke-unknown-method" #t) (! set o "warn-undefined-variable" #t)) @@ -677,9 +679,9 @@ c)) "/tmp/kawa-tmp.zip" env #t)) -(defslimefun compiler-notes-for-emacs (env) +(df compiler-notes-for-emacs ((messages )) (packing (pack) - (do ((e (! get-errors compilation-messages) (@ next e))) + (do ((e (! get-errors messages) (@ next e))) ((nul? e)) (pack (source-error>elisp e))))) @@ -1328,7 +1330,7 @@ ( (! name (! referenceType ex))) ( (!! getName getClass ex))))) (bt (thread-frames tid from to state))) - `((,desc ,type nil) () ,bt ())))) + `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ())))) (df thread-frames ((tid ) (from ) to state) (mlet ((thread level evs) (get state tid #f)) From heller at common-lisp.net Thu Oct 16 21:15:17 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 16 Oct 2008 21:15:17 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv12032 Modified Files: ChangeLog swank-openmcl.lisp Log Message: * swank-openmcl.lisp (frame-catch-tags): Disabled, as it prevents FRAME-LOCALS from working in lx8632. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/11 08:30:52 1.1555 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:15:08 1.1556 @@ -1,3 +1,8 @@ +2008-10-16 Helmut Eller + + * swank-openmcl.lisp (frame-catch-tags): Disabled as it prevents + FRAME-LOCALS from working in lx8632. + 2008-10-10 Nikodemus Siivola * slime.el (slime-inspector-toggle-verbose): New function. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/09/21 11:17:51 1.140 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/10/16 21:15:13 1.141 @@ -54,7 +54,8 @@ (import-from :ccl *gray-stream-symbols* :swank-backend) -(require 'xref) +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'xref)) ;;; swank-mop @@ -527,6 +528,8 @@ result)))) (return-from frame-locals (nreverse result))))))))) + +#+(or) (defimplementation frame-catch-tags (index &aux my-frame) (block frame-catch-tags (map-backtrace @@ -549,6 +552,8 @@ (typep (car tag) 'restart)) `(:restart ,(restart-name (car tag))))))))))))) +(defimplementation frame-catch-tags (index &aux my-frame) nil) + (defimplementation disassemble-frame (the-frame-number) (let ((function-to-disassemble nil)) (block find-frame From heller at common-lisp.net Thu Oct 16 21:15:28 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 16 Oct 2008 21:15:28 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv12183 Modified Files: ChangeLog slime.el swank-abcl.lisp swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp swank-ecl.lisp swank-lispworks.lisp swank-sbcl.lisp swank-scl.lisp Log Message: * swank-backend.lisp (swank-compile-file): Return the same values as COMPILE-FILE. Update backends accordingly. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:15:08 1.1556 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:15:28 1.1557 @@ -1,5 +1,10 @@ 2008-10-16 Helmut Eller + * swank-backend.lisp (swank-compile-file): Return the same + values as COMPILE-FILE. Update backends accordingly. + +2008-10-16 Helmut Eller + * swank-openmcl.lisp (frame-catch-tags): Disabled as it prevents FRAME-LOCALS from working in lx8632. --- /project/slime/cvsroot/slime/slime.el 2008/10/10 06:09:32 1.1047 +++ /project/slime/cvsroot/slime/slime.el 2008/10/16 21:15:28 1.1048 @@ -8967,6 +8967,26 @@ subform))) (slime-check-top-level)) +(def-slime-test (compile-file ("allegro" "lispworks" "clisp")) + (string) + "Insert STRING in a file, and compile it." + `((,(pp-to-string '(defun foo () nil)))) + (let ((filename "/tmp/slime-tmp-file.lisp")) + (with-temp-file filename + (insert string)) + (let ((cell (cons nil nil))) + (slime-eval-async + `(swank:compile-file-for-emacs ,filename nil) + (slime-rcurry (lambda (result cell) + (setcar cell t) + (setcdr cell result)) + cell)) + (slime-wait-condition "Compilation finished" (lambda () (car cell)) + 0.5) + (let ((result (cdr cell))) + (slime-check "Compilation successfull" + (eq (slime-compilation-result.successp result) t)))))) + (def-slime-test async-eval-debugging (depth) "Test recursive debugging of asynchronous evaluation requests." '((1) (2) (3)) --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/09/17 06:19:48 1.55 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/16 21:15:28 1.56 @@ -338,8 +338,10 @@ (let ((*buffer-name* nil) (*compile-filename* filename)) (multiple-value-bind (fn warn fail) (compile-file filename) - (when (and load-p (not fail)) - (load fn))))))) + (values fn warn + (or fail + (and load-p + (not (load fn)))))))))) (defimplementation swank-compile-string (string &key buffer position directory debug) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/04 19:13:41 1.155 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/16 21:15:28 1.156 @@ -371,9 +371,11 @@ (declare (ignore ignore)) `(call-with-compilation-hooks (lambda () (progn , at body)))) -(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. +(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. If supplied, BUFFER and POSITION specify the source location in Emacs. @@ -397,7 +399,8 @@ EXTERNAL-FORMAT is a value returned by find-external-format or :default. -Should return T on successfull compilation, NIL otherwise.") +Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p +like `compile-file'") (deftype severity () '(member :error :read-error :warning :style-warning :note)) --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/09/17 06:19:48 1.78 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/16 21:15:28 1.79 @@ -598,11 +598,12 @@ (defimplementation swank-compile-file (filename load-p external-format) (with-compilation-hooks () (with-compilation-unit () - (let ((fasl-file (compile-file filename - :external-format external-format))) - (when (and load-p fasl-file) - (load fasl-file)) - nil)))) + (multiple-value-bind (fasl-file warningsp failurep) + (compile-file filename :external-format external-format) + (values fasl-file warningsp + (or failurep + (and load-p + (not (load fasl-file))))))))) (defimplementation swank-compile-string (string &key buffer position directory debug) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/11 08:30:57 1.200 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/16 21:15:28 1.201 @@ -371,13 +371,12 @@ (ext:*ignore-extra-close-parentheses* nil)) (multiple-value-bind (output-file warnings-p failure-p) (compile-file filename) - (declare (ignore warnings-p)) - (cond (failure-p nil) - (load-p - ;; Cache the latest source file for definition-finding. - (source-cache-get filename (file-write-date filename)) - (load output-file)) - ((not failure-p))))))) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get filename (file-write-date filename)) + (not (load output-file))))))))) (defimplementation swank-compile-string (string &key buffer position directory debug) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/09/26 23:14:10 1.32 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/10/16 21:15:28 1.33 @@ -145,7 +145,7 @@ (let ((*buffer-name* nil)) (multiple-value-bind (fn warn fail) (compile-file *compile-filename*) - (when load-p (unless fail (load fn))))))) + (values fn warn (or fail (and load-p (not (load fn))))))))) (defimplementation swank-compile-string (string &key buffer position directory debug) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/04 08:04:42 1.118 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/16 21:15:28 1.119 @@ -425,7 +425,8 @@ (defimplementation swank-compile-file (filename load-p external-format) (with-swank-compilation-unit (filename) - (compile-file filename :load load-p :external-format external-format))) + (compile-file filename :load load-p + :external-format external-format))) (defvar *within-call-with-compilation-hooks* nil "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/04 19:13:41 1.223 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/16 21:15:28 1.224 @@ -467,14 +467,15 @@ (defimplementation swank-compile-file (pathname load-p external-format) (handler-case - (let ((output-file (with-compilation-hooks () - (compile-file pathname - :external-format external-format)))) - (when output-file - ;; Cache the latest source file for definition-finding. - (source-cache-get pathname (file-write-date pathname)) - (when load-p - (load output-file)))) + (multiple-value-bind (output-file warnigns-p failure-p) + (with-compilation-hooks () + (compile-file pathname :external-format external-format)) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get pathname (file-write-date pathname)) + (not (load output-file)))))) (sb-c:fatal-compiler-error () nil))) ;;;; compile-string --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/10/04 19:13:41 1.27 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/10/16 21:15:28 1.28 @@ -444,11 +444,12 @@ (ext:*ignore-extra-close-parentheses* nil)) (multiple-value-bind (output-file warnings-p failure-p) (compile-file filename :external-format external-format) - (unless failure-p - ;; Cache the latest source file for definition-finding. - (source-cache-get filename (file-write-date filename)) - (when load-p (load output-file))) - (values output-file warnings-p failure-p))))) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get filename (file-write-date filename)) + (not (load output-file))))))))) (defimplementation swank-compile-string (string &key buffer position directory debug) From heller at common-lisp.net Thu Oct 16 21:15:33 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 16 Oct 2008 21:15:33 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv12728 Modified Files: swank.lisp Log Message: (compile-file-for-emacs): Update for chanded backends. --- /project/slime/cvsroot/slime/swank.lisp 2008/10/10 06:09:32 1.600 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/16 21:15:33 1.601 @@ -2480,9 +2480,12 @@ (lambda () (let ((pathname (filename-to-pathname filename)) (*compile-print* nil) (*compile-verbose* t)) - (swank-compile-file pathname load-p - (or (guess-external-format pathname) - :default))))))) + (multiple-value-bind (output-pathname warnings? failure?) + (swank-compile-file pathname load-p + (or (guess-external-format pathname) + :default)) + (declare (ignore output-pathname warnings?)) + (not failure?))))))) (defslimefun compile-string-for-emacs (string buffer position directory debug) "Compile STRING (exerpted from BUFFER at POSITION). From heller at common-lisp.net Thu Oct 16 21:15:39 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 16 Oct 2008 21:15:39 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv12857/contrib Modified Files: ChangeLog swank-kawa.scm Log Message: * swank-kawa.scm (swank-require): Add a dummy definition to avoid errors at startup. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/11 19:36:48 1.132 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/16 21:15:39 1.133 @@ -1,3 +1,8 @@ +2008-10-16 Helmut Eller + + * swank-kawa.scm (swank-require): Add a dummy definition to avoid + errors at startup. + 2008-10-11 Nikodemus Siivola * slime-scratch.el (slime-scratch-file): New variable. --- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/10/11 19:36:48 1.8 +++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/10/16 21:15:39 1.9 @@ -758,6 +758,7 @@ (defslimefun operator-arglist (#!rest y) '()) (defslimefun buffer-first-change (#!rest y) '()) +(defslimefun swank-require (#!rest y) '()) ;;;; M-. From heller at common-lisp.net Thu Oct 16 21:15:40 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 16 Oct 2008 21:15:40 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv12857 Modified Files: swank.lisp Log Message: * swank-kawa.scm (swank-require): Add a dummy definition to avoid errors at startup. --- /project/slime/cvsroot/slime/swank.lisp 2008/10/16 21:15:33 1.601 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/16 21:15:39 1.602 @@ -122,7 +122,7 @@ (#\return (write-string "\\r" stream)) (t (write-char c stream)))) (write-char #\" stream)) - (t (write-string string))))) + (t (write-string string stream))))) (set-pprint-dispatch 'string #'escape-string 0 table) table))) From heller at common-lisp.net Thu Oct 16 21:15:49 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 16 Oct 2008 21:15:49 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv12991 Modified Files: ChangeLog swank-lispworks.lisp swank.lisp Log Message: * swank-lispworks.lisp (with-swank-compilation-unit): Return the values of BODY. (compile-from-temp-file): Return T on success. * swank.lisp (collect-notes): Check return type of FUNCTION. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:15:28 1.1557 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:15:48 1.1558 @@ -3,6 +3,13 @@ * swank-backend.lisp (swank-compile-file): Return the same values as COMPILE-FILE. Update backends accordingly. + * swank-lispworks.lisp (with-swank-compilation-unit): Return the + values of BODY. + (compile-from-temp-file): Return T on success. + + * swank.lisp (collect-notes): Check return type of + FUNCTION. + 2008-10-16 Helmut Eller * swank-openmcl.lisp (frame-catch-tags): Disabled as it prevents --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/16 21:15:28 1.119 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/16 21:15:48 1.120 @@ -419,9 +419,11 @@ (lw:rebinding (location) `(let ((compiler::*error-database* '())) (with-compilation-unit ,options - , at body - (signal-error-data-base compiler::*error-database* ,location) - (signal-undefined-functions compiler::*unknown-functions* ,location))))) + (multiple-value-prog1 (progn , at body) + (signal-error-data-base compiler::*error-database* + ,location) + (signal-undefined-functions compiler::*unknown-functions* + ,location)))))) (defimplementation swank-compile-file (filename load-p external-format) (with-swank-compilation-unit (filename) @@ -487,11 +489,13 @@ (write-string string s) (finish-output s)) - (let ((binary-filename - (compile-file filename :load t - :external-format *temp-file-format*))) + (multiple-value-bind (binary-filename warnings? failure?) + (compile-file filename :load t + :external-format *temp-file-format*) + (declare (ignore warnings?)) (when binary-filename - (delete-file binary-filename)))) + (delete-file binary-filename)) + (not failure?))) (delete-file filename))) (defun dspec-function-name-position (dspec fallback) --- /project/slime/cvsroot/slime/swank.lisp 2008/10/16 21:15:39 1.602 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/16 21:15:48 1.603 @@ -2470,6 +2470,7 @@ (handler-bind ((compiler-condition (lambda (c) (push (make-compiler-note c) notes)))) (measure-time-interval function)) + (check-type successp boolean) (make-compilation-result (reverse notes) successp seconds)))) (defslimefun compile-file-for-emacs (filename load-p) From heller at common-lisp.net Thu Oct 16 21:16:01 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 16 Oct 2008 21:16:01 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv13148 Modified Files: ChangeLog swank-abcl.lisp swank-allegro.lisp swank-clisp.lisp swank-ecl.lisp Log Message: * swank-lispworks.lisp (with-swank-compilation-unit): Return the values of BODY. (compile-from-temp-file) * swank-allegro.lisp (compile-from-temp-file) * swank-clisp.lisp (swank-compile-string) * swank-abcl.lisp (swank-compile-string): Return T on success. * swank.lisp (collect-notes): Check return type of FUNCTION. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:15:48 1.1558 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:16:01 1.1559 @@ -5,8 +5,10 @@ * swank-lispworks.lisp (with-swank-compilation-unit): Return the values of BODY. - (compile-from-temp-file): Return T on success. - + (compile-from-temp-file) + * swank-allegro.lisp (compile-from-temp-file) + * swank-clisp.lisp (swank-compile-string) + * swank-abcl.lisp (swank-compile-string): Return T on success. * swank.lisp (collect-notes): Check return type of FUNCTION. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/16 21:15:28 1.56 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/16 21:16:01 1.57 @@ -353,7 +353,8 @@ (*buffer-start-position* position) (*buffer-string* string)) (funcall (compile nil (read-from-string - (format nil "(~S () ~A)" 'lambda string)))))))) + (format nil "(~S () ~A)" 'lambda string)))) + t)))) #| ;;;; Definition Finding --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/09/19 11:20:15 1.115 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/16 21:16:01 1.116 @@ -301,14 +301,16 @@ (lambda (stream filename) (write-string string stream) (finish-output stream) - (let ((binary-filename - (excl:without-redefinition-warnings - ;; Suppress Allegro's redefinition warnings; they are - ;; pointless when we are compiling via a temporary - ;; file. - (compile-file filename :load-after-compile t)))) + (multiple-value-bind (binary-filename warnings? failure?) + (excl:without-redefinition-warnings + ;; Suppress Allegro's redefinition warnings; they are + ;; pointless when we are compiling via a temporary + ;; file. + (compile-file filename :load-after-compile t)) + (declare (ignore warnings?)) (when binary-filename - (delete-file binary-filename)))))) + (delete-file binary-filename)) + (not failure?))))) (defimplementation swank-compile-string (string &key buffer position directory debug) --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/16 21:15:28 1.79 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/16 21:16:01 1.80 @@ -612,7 +612,8 @@ (let ((*buffer-name* buffer) (*buffer-offset* position)) (funcall (compile nil (read-from-string - (format nil "(~S () ~A)" 'lambda string))))))) + (format nil "(~S () ~A)" 'lambda string)))) + t))) ;;;; Portable XREF from the CMU AI repository. --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/10/16 21:15:28 1.33 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/10/16 21:16:01 1.34 @@ -143,9 +143,7 @@ (declare (ignore external-format)) (with-compilation-hooks () (let ((*buffer-name* nil)) - (multiple-value-bind (fn warn fail) - (compile-file *compile-filename*) - (values fn warn (or fail (and load-p (not (load fn))))))))) + (compile-file *compile-filename* :load t)))) (defimplementation swank-compile-string (string &key buffer position directory debug) @@ -155,7 +153,7 @@ (*buffer-start-position* position) (*buffer-string* string)) (with-input-from-string (s string) - (compile-from-stream s :load t))))) + (not (nth-value 2 (compile-from-stream s :load t))))))) (defun compile-from-stream (stream &rest args) (let ((file (si::mkstemp "TMP:ECLXXXXXX"))) From heller at common-lisp.net Fri Oct 17 21:26:54 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 17 Oct 2008 21:26:54 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv30786 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: * swank-backend.lisp (frame-restartable-p): New function. (swank-frame): Deleted. Update implemenetations accordingly. (print-frame): Renamed back from print-swank-frame. * swank.lisp (backtrace): Don't clutter the backtrace with '(:restartable :unknown). For practical purposes :unknown is the same as nil. * slime.el (sldb-compute-frame-face): Only accept nil or t for the :restartable prop. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/16 21:16:01 1.1559 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:26:53 1.1560 @@ -1,3 +1,16 @@ +2008-10-17 Helmut Eller + + * swank-backend.lisp (frame-restartable-p): New function. + (swank-frame): Deleted. Update implemenetations accordingly. + (print-frame): Renamed back from print-swank-frame. + + * swank.lisp (backends): Don't clutter the backtrace with + '(:restartable :unknown). For practical purposes :unknown is the + same as nil. + + * slime.el (sldb-compute-frame-face): Only accept nil or t for + the :restartable prop. + 2008-10-16 Helmut Eller * swank-backend.lisp (swank-compile-file): Return the same --- /project/slime/cvsroot/slime/slime.el 2008/10/16 21:15:28 1.1048 +++ /project/slime/cvsroot/slime/slime.el 2008/10/17 21:26:53 1.1049 @@ -6876,7 +6876,8 @@ (when more (slime-insert-propertized `(, at nil sldb-default-action sldb-fetch-more-frames - sldb-previous-frame-number ,(sldb-frame.number (first (last frames))) + sldb-previous-frame-number + ,(sldb-frame.number (first (last frames))) point-entered sldb-fetch-more-frames start-open t face sldb-section-face @@ -6885,14 +6886,9 @@ (insert "\n"))) (defun sldb-compute-frame-face (frame) - (let ((restartable (getf (sldb-frame.plist frame) :restartable))) - (cond ((eq restartable 't) - 'sldb-restartable-frame-line-face) - ((eq restartable :unknown) - 'sldb-frame-line-face) - ((eq restartable 'nil) - 'sldb-non-restartable-frame-line-face) - (t (error "fall through"))))) + (ecase (plist-get (sldb-frame.plist frame) :restartable) + ((nil) 'sldb-frame-line-face) + ((t) 'sldb-restartable-frame-line-face))) (defun sldb-insert-frame (frame &optional face) "Insert FRAME with FACE at point. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/16 21:16:01 1.57 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/17 21:26:53 1.58 @@ -253,11 +253,11 @@ (defimplementation compute-backtrace (start end) (let ((end (or end most-positive-fixnum))) (loop for f in (subseq (backtrace-as-list-ignoring-swank-calls) start end) - collect (make-swank-frame :%frame f :restartable :unknown)))) + collect f))) -(defimplementation print-swank-frame (frame stream) +(defimplementation print-frame (frame stream) (write-string (string-trim '(#\space #\newline) - (prin1-to-string (swank-frame.%frame frame))) + (prin1-to-string frame)) stream)) (defimplementation frame-locals (index) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/16 21:16:01 1.116 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/17 21:26:53 1.117 @@ -163,10 +163,10 @@ (let ((end (or end most-positive-fixnum))) (loop for f = (nth-frame start) then (next-frame f) for i from start below end - while f collect (make-swank-frame :%frame f :restartable :unknown)))) + while f collect f))) -(defimplementation print-swank-frame (frame stream) - (debugger:output-frame stream (swank-frame.%frame frame) :moderate)) +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) (defimplementation frame-locals (index) (let ((frame (nth-frame index))) @@ -210,6 +210,9 @@ form (debugger:environment-of-frame frame))))) +(defimplementation frame-restartable-p (frame) + (debugger:frame-retryable-p frame)) + (defimplementation restart-frame (frame-number) (let ((frame (nth-frame frame-number))) (cond ((debugger:frame-retryable-p frame) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/16 21:15:28 1.156 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/17 21:26:53 1.157 @@ -20,9 +20,6 @@ #:condition #:severity #:with-compilation-hooks - #:swank-frame - #:swank-frame-p - #:swank-frame.restartable #:location #:location-p #:location-buffer @@ -656,13 +653,9 @@ ;;; The following functions in this section are supposed to be called ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. -(defstruct (swank-frame (:conc-name swank-frame.)) - %frame - restartable) - (definterface compute-backtrace (start end) "Returns a backtrace of the condition currently being debugged, -that is an ordered list consisting of swank-frames. ``Ordered list'' +that is an ordered list consisting of frames. ``Ordered list'' means that an integer I can be mapped back to the i-th frame of this backtrace. @@ -671,9 +664,14 @@ debugger. If END is nil, return the frames from START to the end of the stack.") -(definterface print-swank-frame (frame stream) +(definterface print-frame (frame stream) "Print frame to stream.") +(definterface frame-restartable-p (frame) + "Is the frame FRAME restartable?. +Return T if `restart-frame' can safely be called on the frame." + nil) + (definterface frame-source-location-for-emacs (frame-number) "Return the source location for the frame associated to FRAME-NUMBER.") --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/16 21:16:01 1.80 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/17 21:26:53 1.81 @@ -349,7 +349,7 @@ (let* ((bt *sldb-backtrace*) (len (length bt))) (loop for f in (subseq bt start (min (or end len) len)) - collect (make-swank-frame :%frame f :restartable :unknown)))) + collect f))) ;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we ;;; can omit that restart so that users don't select it by mistake. @@ -358,9 +358,8 @@ ;; list, hopefully that's our unwanted ABORT restart. (butlast (compute-restarts condition))) -(defimplementation print-swank-frame (swank-frame stream) - (let* ((frame (swank-frame.%frame swank-frame)) - (str (frame-to-string frame))) +(defimplementation print-frame (frame stream) + (let* ((str (frame-to-string frame))) (write-string (extract-frame-line str) stream))) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/16 21:15:28 1.201 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/10/17 21:26:53 1.202 @@ -1502,11 +1502,10 @@ (let ((end (or end most-positive-fixnum))) (loop for f = (nth-frame start) then (frame-down f) for i from start below end - while f collect (make-swank-frame :%frame f :restartable :unknown)))) + while f collect f))) -(defimplementation print-swank-frame (swank-frame stream) - (let ((frame (swank-frame.%frame swank-frame)) - (*standard-output* stream)) +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) (handler-case (debug::print-frame-call frame :verbosity 1 :number nil) (error (e) --- /project/slime/cvsroot/slime/swank-corman.lisp 2008/09/17 06:19:48 1.18 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/10/17 21:26:53 1.19 @@ -177,10 +177,10 @@ (defimplementation compute-backtrace (start end) (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) - collect (make-swank-frame :%frame f :restartable :unknown))) + collect f)) -(defimplementation print-swank-frame (frame stream) - (format stream "~S" (swank-frame.%frame frame))) +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) (defun get-frame-debug-info (frame) (or (frame-debug-info frame) @@ -370,9 +370,10 @@ (declare (ignore external-format)) (with-compilation-hooks () (let ((*buffer-name* nil)) - (compile-file *compile-filename*) - (when load-p - (load (compile-file-pathname *compile-filename*)))))) + (multiple-value-bind (output-file warnings? failure?) + (compile-file *compile-filename*) + (values output-file warnings? + (or failure? (and load-p (load output-file)))))))) (defimplementation swank-compile-string (string &key buffer position directory debug) @@ -382,7 +383,8 @@ (*buffer-position* position) (*buffer-string* string)) (funcall (compile nil (read-from-string - (format nil "(~S () ~A)" 'lambda string))))))) + (format nil "(~S () ~A)" 'lambda string)))) + t))) ;;;; Inspecting --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/10/16 21:16:01 1.34 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/10/17 21:26:53 1.35 @@ -316,7 +316,7 @@ (when (numberp end) (setf end (min end (length *backtrace*)))) (loop for f in (subseq *backtrace* start end) - collect (make-swank-frame :%frame f :restartable :unknown))) + collect f)) (defun frame-name (frame) (let ((x (first frame))) @@ -356,9 +356,8 @@ )))) (values functions blocks variables))) -(defimplementation print-swank-frame (swank-frame stream) - (let ((frame (swank-frame.%frame swank-frame))) - (format stream "~A" (first frame)))) +(defimplementation print-frame (frame stream) + (format stream "~A" (first frame))) (defimplementation frame-source-location-for-emacs (frame-number) (nth-value 1 (frame-function (elt *backtrace* frame-number)))) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/16 21:15:48 1.120 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/17 21:26:53 1.121 @@ -318,8 +318,7 @@ ((or (not frame) (= i end)) (nreverse backtrace)) (when (interesting-frame-p frame) (incf i) - (push (make-swank-frame :%frame frame :restartable :unknown) - backtrace))))) + (push frame backtrace))))) (defun frame-actual-args (frame) (let ((*break-on-signals* nil)) @@ -331,13 +330,12 @@ (error (e) (format nil "<~A>" arg)))))) (dbg::call-frame-arglist frame)))) -(defimplementation print-swank-frame (swank-frame stream) - (let ((frame (swank-frame.%frame swank-frame))) - (cond ((dbg::call-frame-p frame) - (format stream "~S ~S" - (dbg::call-frame-function-name frame) - (frame-actual-args frame))) - (t (princ frame stream))))) +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (format stream "~S ~S" + (dbg::call-frame-function-name frame) + (frame-actual-args frame))) + (t (princ frame stream)))) (defun frame-vars (frame) (first (dbg::frame-locals-format-list frame #'list 75 0))) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/10/16 21:15:13 1.141 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/10/17 21:26:53 1.142 @@ -492,19 +492,17 @@ (let (result) (map-backtrace (lambda (frame-number p context lfun pc) (declare (ignore frame-number)) - (push (make-swank-frame :%frame (list :openmcl-frame p context lfun pc) - :restartable :unknown) + (push (list :frame p context lfun pc) result)) start-frame-number end-frame-number) (nreverse result))) -(defimplementation print-swank-frame (swank-frame stream) - (let ((frame (swank-frame.%frame swank-frame))) - (assert (eq (first frame) :openmcl-frame)) - (destructuring-bind (p context lfun pc) (rest frame) - (format stream "(~S~{ ~S~})" - (or (ccl::function-name lfun) lfun) - (frame-arguments p context lfun pc))))) +(defimplementation print-frame (frame stream) + (assert (eq (first frame) :frame)) + (destructuring-bind (p context lfun pc) (rest frame) + (format stream "(~S~{ ~S~})" + (or (ccl::function-name lfun) lfun) + (frame-arguments p context lfun pc))))) (defimplementation frame-locals (index) (block frame-locals @@ -963,7 +961,7 @@ (nconc (ldiff q tail) (cdr tail))) (return (car tail))))) (when (eq timeout t) (return (values nil t))) - (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 0.2)))) + (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 1)))) (defimplementation quit-lisp () (ccl::quit)) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/16 21:15:28 1.224 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/17 21:26:53 1.225 @@ -882,16 +882,14 @@ (let ((end (or end most-positive-fixnum))) (loop for f = (nth-frame start) then (sb-di:frame-down f) for i from start below end - while f collect (make-swank-frame - :%frame f - :restartable (frame-restartable-p f))))) + while f collect f))) -(defimplementation print-swank-frame (swank-frame stream) - (sb-debug::print-frame-call (swank-frame.%frame swank-frame) stream)) +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream)) -(defun frame-restartable-p (frame) +(defimplementation frame-restartable-p (frame) #+#.(swank-backend::sbcl-with-restart-frame) - (sb-debug:frame-has-debug-tag-p frame)) + (not (null (sb-debug:frame-has-debug-tag-p frame)))) ;;;; Code-location -> source-location translation --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/10/16 21:15:28 1.28 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/10/17 21:26:53 1.29 @@ -1354,11 +1354,10 @@ (let ((end (or end most-positive-fixnum))) (loop for f = (nth-frame start) then (frame-down f) for i from start below end - while f collect (make-swank-frame :%frame f :restartable :unknown)))) + while f collect f))) -(defimplementation print-swank-frame (swank-frame stream) - (let ((frame (swank-frame.%frame swank-frame)) - (*standard-output* stream)) +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) (handler-case (debug::print-frame-call frame :verbosity 1 :number nil) (error (e) --- /project/slime/cvsroot/slime/swank.lisp 2008/10/16 21:15:48 1.603 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/17 21:26:53 1.604 @@ -2294,21 +2294,21 @@ I is an integer, and can be used to reference the corresponding frame from Emacs; FRAME is a string representation of an implementation's frame." - (flet ((print-swank-frame-to-string (frame) - (call/truncated-output-to-string - 100 - (lambda (stream) - (handler-case - (with-bindings *backtrace-printer-bindings* - (print-swank-frame frame stream)) - (t () - (format stream "[error printing frame]"))))))) - (loop for frame in (compute-backtrace start end) - for i from start collect - (list i (print-swank-frame-to-string frame) - (list :restartable (let ((r (swank-frame.restartable frame))) - (check-type r (member nil t :unknown)) - r)))))) + (loop for frame in (compute-backtrace start end) + for i from start collect + (list* i (frame-to-string frame) + (ecase (frame-restartable-p frame) + ((nil) nil) + ((t) `((:restartable t))))))) + +(defun frame-to-string (frame) + (with-bindings *backtrace-printer-bindings* + (call/truncated-output-to-string + (* (or *print-lines* 1) (or *print-right-margin* 100)) + (lambda (stream) + (handler-case (print-frame frame stream) + (serious-condition () + (format stream "[error printing frame]"))))))) (defslimefun debugger-info-for-emacs (start end) "Return debugger state, with stack frames from START to END. From heller at common-lisp.net Fri Oct 17 21:26:59 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 17 Oct 2008 21:26:59 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv30902 Modified Files: swank-openmcl.lisp Log Message: (print-frame): Fix parens. --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/10/17 21:26:53 1.142 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/10/17 21:26:58 1.143 @@ -502,7 +502,7 @@ (destructuring-bind (p context lfun pc) (rest frame) (format stream "(~S~{ ~S~})" (or (ccl::function-name lfun) lfun) - (frame-arguments p context lfun pc))))) + (frame-arguments p context lfun pc)))) (defimplementation frame-locals (index) (block frame-locals From heller at common-lisp.net Fri Oct 17 21:27:08 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 17 Oct 2008 21:27:08 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv30944 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (call-with-retry-restart): Implement this a little less confusing. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:26:53 1.1560 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:27:08 1.1561 @@ -1,10 +1,15 @@ 2008-10-17 Helmut Eller + * swank.lisp (call-with-retry-restart): Implement this a little + less confusing. + +2008-10-17 Helmut Eller + * swank-backend.lisp (frame-restartable-p): New function. (swank-frame): Deleted. Update implemenetations accordingly. (print-frame): Renamed back from print-swank-frame. - * swank.lisp (backends): Don't clutter the backtrace with + * swank.lisp (backtrace): Don't clutter the backtrace with '(:restartable :unknown). For practical purposes :unknown is the same as nil. --- /project/slime/cvsroot/slime/swank.lisp 2008/10/17 21:26:53 1.604 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/17 21:27:08 1.605 @@ -413,16 +413,8 @@ (call-with-debugger-hook #'swank-debugger-hook function))))))) (defun call-with-retry-restart (msg thunk) - (let ((%ok (gensym "OK+")) - (%retry (gensym "RETRY+"))) - (restart-bind - ((retry - (lambda () (throw %retry nil)) - :report-function - (lambda (stream) - (write msg :stream stream)))) - (catch %ok - (loop (catch %retry (throw %ok (funcall thunk)))))))) + (loop (with-simple-restart (retry "~a" msg) + (return (funcall thunk))))) (defmacro with-retry-restart ((&key (msg "Retry.")) &body body) (check-type msg string) From heller at common-lisp.net Fri Oct 17 21:27:16 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 17 Oct 2008 21:27:16 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv30977 Modified Files: ChangeLog swank-backend.lisp swank-clisp.lisp swank.lisp Log Message: * swank-backend.lisp (compute-sane-restarts): Deleted. Use plain compute restarts instead. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:27:08 1.1561 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:27:16 1.1562 @@ -1,5 +1,10 @@ 2008-10-17 Helmut Eller + * swank-backend.lisp (compute-sane-restarts): Deleted. Use plain + compute restarts instead. + +2008-10-17 Helmut Eller + * swank.lisp (call-with-retry-restart): Implement this a little less confusing. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/17 21:26:53 1.157 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/17 21:27:16 1.158 @@ -643,13 +643,6 @@ user without (re)entering the debugger by wrapping them as `sldb-condition's.")) -(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, -otherwise it should simply call CL:COMPUTE-RESTARTS, which is -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. --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/17 21:26:53 1.81 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/17 21:27:16 1.82 @@ -351,13 +351,6 @@ (loop for f in (subseq bt start (min (or end len) len)) collect f))) -;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we -;;; can omit that restart so that users don't select it by mistake. -(defimplementation compute-sane-restarts (condition) - ;; The outermost restart is specified to be the last element of the - ;; list, hopefully that's our unwanted ABORT restart. - (butlast (compute-restarts condition))) - (defimplementation print-frame (frame stream) (let* ((str (frame-to-string frame))) (write-string (extract-frame-line str) --- /project/slime/cvsroot/slime/swank.lisp 2008/10/17 21:27:08 1.605 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/17 21:27:16 1.606 @@ -2196,7 +2196,7 @@ (defun debug-in-emacs (condition) (let ((*swank-debugger-condition* condition) - (*sldb-restarts* (compute-sane-restarts condition)) + (*sldb-restarts* (compute-restarts condition)) (*package* (or (and (boundp '*buffer-package*) (symbol-value '*buffer-package*)) *package*)) From heller at common-lisp.net Fri Oct 17 21:27:24 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 17 Oct 2008 21:27:24 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv31045 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (swank-compile-file): Fix typo. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:27:16 1.1562 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:27:24 1.1563 @@ -1,5 +1,9 @@ 2008-10-17 Helmut Eller + * swank-sbcl.lisp (swank-compile-file): Fix typo. + +2008-10-17 Helmut Eller + * swank-backend.lisp (compute-sane-restarts): Deleted. Use plain compute restarts instead. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/17 21:26:53 1.225 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/17 21:27:24 1.226 @@ -467,7 +467,7 @@ (defimplementation swank-compile-file (pathname load-p external-format) (handler-case - (multiple-value-bind (output-file warnigns-p failure-p) + (multiple-value-bind (output-file warnings-p failure-p) (with-compilation-hooks () (compile-file pathname :external-format external-format)) (values output-file warnings-p From heller at common-lisp.net Sun Oct 19 20:03:12 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 19 Oct 2008 20:03:12 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv4330 Modified Files: ChangeLog swank-clisp.lisp Log Message: * swank-clisp.lisp (filename-to-pathname, parse-cygwin-filename): Accept Windows and Unix filenames when :CYGWIN is in *features*. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/17 21:27:24 1.1563 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/19 20:03:12 1.1564 @@ -1,3 +1,8 @@ +2008-10-19 Helmut Eller + + * swank-clisp.lisp (filename-to-pathname, parse-cygwin-filename): + Accept Windows and Unix filenames when :CYGWIN is in *features*. + 2008-10-17 Helmut Eller * swank-sbcl.lisp (swank-compile-file): Fix typo. --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/17 21:27:16 1.82 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/19 20:03:12 1.83 @@ -116,6 +116,47 @@ (setf (ext:default-directory) directory) (namestring (setf *default-pathname-defaults* (ext:default-directory)))) +(defimplementation filename-to-pathname (string) + (cond ((member :cygwin *features*) + (parse-cygwin-filename string)) + (t (parse-namestring string)))) + +(defun parse-cygwin-filename (string) + (multiple-value-bind (match _ drive absolute) + (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) + (declare (ignore _)) + (assert (and match (if drive absolute t)) () + "Invalid filename syntax: ~a" string) + (let* ((sans-prefix (subseq string (regexp:match-end match))) + (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) + (path (loop for name in path collect + (cond ((equal name "..") ':back) + (t name)))) + (directoryp (or (equal string "") + (find (aref string (1- (length string))) "\\/")))) + (multiple-value-bind (file type) + (cond ((and (not directoryp) (last path)) + (let* ((file (car (last path))) + (pos (position #\. file :from-end t))) + (cond ((and pos (> pos 0)) + (values (subseq file 0 pos) + (subseq file (1+ pos)))) + (t file))))) + (make-pathname :host nil + :device nil + :directory (cons + (if absolute :absolute :relative) + (let ((path (if directoryp + path + (butlast path)))) + (if drive + (cons + (regexp:match-string string drive) + path) + path))) + :name file + :type type))))) + ;;;; TCP Server (defimplementation create-socket (host port) From heller at common-lisp.net Sun Oct 19 20:03:23 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 19 Oct 2008 20:03:23 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv4386 Modified Files: ChangeLog swank-abcl.lisp Log Message: * swank-abcl.lisp (handle-compiler-warning): Report source location position when we can. Use NAMESTRING for *compile-filename*. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/19 20:03:12 1.1564 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/19 20:03:21 1.1565 @@ -1,3 +1,9 @@ +2008-10-19 Mark Evenson + + * swank-abcl.lisp (handle-compiler-warning): Report source + location position when we can. + Use NAMESTRING for *compile-filename*. + 2008-10-19 Helmut Eller * swank-clisp.lisp (filename-to-pathname, parse-cygwin-filename): --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/17 21:26:53 1.58 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/19 20:03:22 1.59 @@ -127,7 +127,6 @@ (defimplementation local-port (socket) (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket)) - (defimplementation close-socket (socket) (ext:server-socket-close socket)) @@ -263,7 +262,6 @@ (defimplementation frame-locals (index) `(,(list :name "??" :id 0 :value "??"))) - (defimplementation frame-catch-tags (index) (declare (ignore index)) nil) @@ -306,8 +304,11 @@ (in-package :swank-backend) (defun handle-compiler-warning (condition) - (let ((loc nil));(getf (slot-value condition 'excl::plist) :loc))) - (unless (member condition *abcl-signaled-conditions*) ; filter condition signaled more than once. + (let ((loc (when (and jvm::*compile-file-pathname* + system::*source-position*) + (cons jvm::*compile-file-pathname* system::*source-position*)))) + ;; filter condition signaled more than once. + (unless (member condition *abcl-signaled-conditions*) (push condition *abcl-signaled-conditions*) (signal (make-condition 'compiler-condition @@ -325,7 +326,7 @@ (list :position (1+ pos))))) (t (make-location - (list :file *compile-filename*) + (list :file (namestring *compile-filename*)) (list :position 1))))))))) (defvar *abcl-signaled-conditions*) From heller at common-lisp.net Sun Oct 19 20:03:34 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 19 Oct 2008 20:03:34 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv4440 Modified Files: ChangeLog slime.el swank-abcl.lisp swank-allegro.lisp swank-backend.lisp swank-clisp.lisp swank-corman.lisp swank-lispworks.lisp swank-openmcl.lisp swank.lisp Log Message: * swank.lisp (frame-locals-and-catch-tags): New function. Fetch locals and catch tags with a single RPC. * slime.el (sldb-frame-details): Use it. * swank-backend.lisp (frame-catch-tags): Provide a default implementation. Delete the dummy defs in various backends. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/19 20:03:21 1.1565 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/19 20:03:34 1.1566 @@ -1,3 +1,13 @@ +2008-10-19 Helmut Eller + + * swank.lisp (frame-locals-and-catch-tags): New function. + Fetch locals and catch tags with a single RPC. + + * slime.el (sldb-frame-details): Use it. + + * swank-backend.lisp (frame-catch-tags): Provide a default + implementation. Delete the dummy defs in various backends. + 2008-10-19 Mark Evenson * swank-abcl.lisp (handle-compiler-warning): Report source --- /project/slime/cvsroot/slime/slime.el 2008/10/17 21:26:53 1.1049 +++ /project/slime/cvsroot/slime/slime.el 2008/10/19 20:03:34 1.1050 @@ -7173,13 +7173,13 @@ (defun sldb-frame-details () ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point. (let* ((frame (get-text-property (point) 'frame)) - (num (car frame)) - (catches (sldb-catch-tags num)) - (locals (sldb-frame-locals num))) + (num (car frame))) (destructuring-bind (start end) (sldb-frame-region) - (list start end frame locals catches)))) + (list* start end frame + (slime-eval `(swank:frame-locals-and-catch-tags ,num)))))) -(defvar sldb-insert-frame-variable-value-function 'sldb-insert-frame-variable-value) +(defvar sldb-insert-frame-variable-value-function + 'sldb-insert-frame-variable-value) (defun sldb-insert-locals (vars prefix frame) "Insert VARS and add PREFIX at the beginning of each inserted line. @@ -7226,12 +7226,6 @@ (first sldb-condition) (second sldb-condition)))) -(defun sldb-frame-locals (frame) - (slime-eval `(swank:frame-locals-for-emacs ,frame))) - -(defun sldb-catch-tags (frame) - (slime-eval `(swank:frame-catch-tags-for-emacs ,frame))) - ;;;;;; SLDB eval and inspect --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/19 20:03:22 1.59 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/10/19 20:03:34 1.60 @@ -262,10 +262,6 @@ (defimplementation frame-locals (index) `(,(list :name "??" :id 0 :value "??"))) -(defimplementation frame-catch-tags (index) - (declare (ignore index)) - nil) - #+nil (defimplementation disassemble-frame (index) (disassemble (debugger:frame-function (nth-frame index)))) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/17 21:26:53 1.117 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/19 20:03:34 1.118 @@ -178,10 +178,6 @@ (defimplementation frame-var-value (frame var) (let ((frame (nth-frame frame))) (debugger:frame-var-value frame var))) - -(defimplementation frame-catch-tags (index) - (declare (ignore index)) - nil) (defimplementation disassemble-frame (index) (disassemble (debugger:frame-function (nth-frame index)))) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/17 21:27:16 1.158 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/19 20:03:34 1.159 @@ -670,7 +670,8 @@ (definterface frame-catch-tags (frame-number) "Return a list of catch tags for being printed in a debugger stack -frame.") +frame." + '()) (definterface frame-locals (frame-number) "Return a list of ((&key NAME ID VALUE) ...) where each element of --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/19 20:03:12 1.83 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/10/19 20:03:34 1.84 @@ -513,10 +513,6 @@ (not (mismatch pattern string :end2 (min (length pattern) (length string))))) -(defimplementation frame-catch-tags (index) - (declare (ignore index)) - nil) - (defimplementation return-from-frame (index form) (sys::return-from-eval-frame (nth-frame index) form)) --- /project/slime/cvsroot/slime/swank-corman.lisp 2008/10/17 21:26:53 1.19 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/10/19 20:03:34 1.20 @@ -203,10 +203,6 @@ (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 --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/17 21:26:53 1.121 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/19 20:03:34 1.122 @@ -356,10 +356,6 @@ (declare (ignore _n _s _l)) value))) -(defimplementation frame-catch-tags (index) - (declare (ignore index)) - nil) - (defimplementation frame-source-location-for-emacs (frame) (let ((frame (nth-frame frame)) (callee (if (plusp frame) (nth-frame (1- frame))))) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/10/17 21:26:58 1.143 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/10/19 20:03:34 1.144 @@ -527,7 +527,7 @@ (return-from frame-locals (nreverse result))))))))) -#+(or) +#+(or) ;; Doesn't work well on x86-32 (defimplementation frame-catch-tags (index &aux my-frame) (block frame-catch-tags (map-backtrace @@ -550,8 +550,6 @@ (typep (car tag) 'restart)) `(:restart ,(restart-name (car tag))))))))))))) -(defimplementation frame-catch-tags (index &aux my-frame) nil) - (defimplementation disassemble-frame (the-frame-number) (let ((function-to-disassemble nil)) (block find-frame --- /project/slime/cvsroot/slime/swank.lisp 2008/10/17 21:27:16 1.606 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/19 20:03:34 1.607 @@ -2385,18 +2385,20 @@ (multiple-value-list (eval-in-frame (wrap-sldb-vars (from-string string)) index))))) -(defslimefun frame-locals-for-emacs (index) - "Return a property list ((&key NAME ID VALUE) ...) describing -the local variables in the frame INDEX." - (with-bindings *backtrace-printer-bindings* - (mapcar (lambda (frame-locals) - (destructuring-bind (&key name id value) frame-locals - (list :name (prin1-to-string name) :id id - :value (to-line value)))) - (frame-locals index)))) +(defslimefun frame-locals-and-catch-tags (index) + "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. +LOCALS is a list of the form ((&key NAME ID VALUE) ...). +TAGS has is a list of strings." + (list (frame-locals-for-emacs index) + (mapcar #'to-string (frame-catch-tags index)))) -(defslimefun frame-catch-tags-for-emacs (frame-index) - (mapcar #'to-string (frame-catch-tags frame-index))) +(defun frame-locals-for-emacs (index) + (with-bindings *backtrace-printer-bindings* + (loop for var in (frame-locals index) + collect (destructuring-bind (&key name id value) var + (list :name (prin1-to-string name) + :id id + :value (to-line value)))))) (defslimefun sldb-disassemble (index) (with-output-to-string (*standard-output*) From heller at common-lisp.net Sun Oct 19 20:03:39 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 19 Oct 2008 20:03:39 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv4548 Modified Files: swank-backend.lisp Log Message: (frame-catch-tags): Add ignore decl. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/19 20:03:34 1.159 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/19 20:03:39 1.160 @@ -671,6 +671,7 @@ (definterface frame-catch-tags (frame-number) "Return a list of catch tags for being printed in a debugger stack frame." + (declare (ignore frame-number)) '()) (definterface frame-locals (frame-number) From heller at common-lisp.net Sun Oct 19 20:03:44 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 19 Oct 2008 20:03:44 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv4590 Modified Files: swank-backend.lisp Log Message: (frame-restartable-p): Add ignore decl. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/19 20:03:39 1.160 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/19 20:03:44 1.161 @@ -663,6 +663,7 @@ (definterface frame-restartable-p (frame) "Is the frame FRAME restartable?. Return T if `restart-frame' can safely be called on the frame." + (declare (ignore frame)) nil) (definterface frame-source-location-for-emacs (frame-number) From heller at common-lisp.net Sun Oct 19 20:03:49 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 19 Oct 2008 20:03:49 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv4644 Modified Files: swank-backend.lisp Log Message: More ignore decls. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/19 20:03:44 1.161 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/10/19 20:03:49 1.162 @@ -310,6 +310,7 @@ (definterface install-sigint-handler (function) "Call FUNCTION on SIGINT (instead of invoking the debugger). Return old signal handler." + (declare (ignore function)) nil) (definterface call-with-user-break-handler (handler function) @@ -966,6 +967,7 @@ "Return the thread for ID. ID should be an id previously obtained with THREAD-ID. Can return nil if the thread no longer exists." + (declare (ignore id)) (current-thread)) (definterface thread-name (thread) From heller at common-lisp.net Sun Oct 19 20:03:56 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 19 Oct 2008 20:03:56 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv4684/contrib Modified Files: ChangeLog swank-goo.goo swank-kawa.scm swank-mit-scheme.scm Log Message: * swank-mit-scheme.scm (swank:frame-locals-and-catch-tags) * swank-kawa.scm (dispatch-events) * swank-goo.goo (frame-locals-and-catch-tags): Update backends for the new swank:frame-locals-and-catch-tags. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/16 21:15:39 1.133 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/19 20:03:55 1.134 @@ -1,3 +1,10 @@ +2008-10-19 Helmut Eller + + * swank-mit-scheme.scm (swank:frame-locals-and-catch-tags) + * swank-kawa.scm (dispatch-events) + * swank-goo.goo (frame-locals-and-catch-tags): Update + backends for the new swank:frame-locals-and-catch-tags. + 2008-10-16 Helmut Eller * swank-kawa.scm (swank-require): Add a dummy definition to avoid --- /project/slime/cvsroot/slime/contrib/swank-goo.goo 2008/01/19 14:08:27 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-goo.goo 2008/10/19 20:03:55 1.2 @@ -228,14 +228,14 @@ start (if (isa? end ) end #f)))) -(defslimefun frame-locals-for-emacs (frame-idx) +(defslimefun frame-locals-and-catch-tags (frame-idx) (def frame (nth-frame frame-idx)) - (map-keyed (fun (i name) - (lst ':name (sym-name name) ':id 0 - ':value (safe-write-to-string (frame-var-value frame i)))) - (frame-var-names frame))) - -(defslimefun frame-catch-tags-for-emacs (frame-idx) '()) + (list + (map-keyed (fun (i name) + (lst ':name (sym-name name) ':id 0 + ':value (safe-write-to-string (frame-var-value frame i)))) + (frame-var-names frame)) + '())) (defslimefun inspect-frame-var (frame-idx var-idx) (reset-inspector) --- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/10/16 21:15:39 1.9 +++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/10/19 20:03:55 1.10 @@ -375,12 +375,9 @@ ((_ (':emacs-rex ('|swank:frame-source-location-for-emacs| frame) pkg thread id)) (send dbg `(frame-src-loc ,thread ,frame ,id))) - ((_ (':emacs-rex ('|swank:frame-locals-for-emacs| frame) + ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame) pkg thread id)) - (send dbg `(frame-locals ,thread ,frame ,id))) - ((_ (':emacs-rex ('|swank:frame-catch-tags-for-emacs| frame) - pkg thread id)) - (send dbg `(frame-catchers ,thread ,frame ,id))) + (send dbg `(frame-details ,thread ,frame ,id))) ((_ (':emacs-rex ('|swank:sldb-disassemble| frame) pkg thread id)) (send dbg `(disassemble-frame ,thread ,frame ,id))) @@ -1179,10 +1176,8 @@ (set state (thread-continue thread id c state))) ((,c . ('frame-src-loc thread frame id)) (reply c (frame-src-loc thread frame state) id)) - ((,c . ('frame-locals thread frame id)) - (reply c (frame-locals thread frame state) id)) - ((,c . ('frame-catchers thread frame id)) - (reply c (frame-catchers thread frame state) id)) + ((,c . ('frame-details thread frame id)) + (reply c (list (frame-locals thread frame state) '()) id)) ((,c . ('disassemble-frame thread frame id)) (reply c (disassemble-frame thread frame state) id)) ((,c . ('thread-frames thread from to id)) @@ -1454,9 +1449,6 @@ (pack (list (! name var) val))))))) ( '())))) -(df frame-catchers ((tid ) (frame ) state) - '()) - (df disassemble-frame ((tid ) (frame ) state) (mlet ((frame _) (nth-frame tid frame state)) (typecase frame --- /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm 2008/03/18 13:22:05 1.3 +++ /project/slime/cvsroot/slime/contrib/swank-mit-scheme.scm 2008/10/19 20:03:55 1.4 @@ -395,7 +395,6 @@ ;;; Some unimplemented stuff. (define (swank:buffer-first-change . _) nil) -(define (swank:frame-catch-tags-for-emacs . _) nil) (define (swank:filename-to-modulename . _) nil) ;; M-. is beyond my capabilities. @@ -525,8 +524,9 @@ ((< i from) (loop (1+ i) l (stream-cdr s))) (else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s)))))) -(define (swank:frame-locals-for-emacs _ frame) - (map frame-var>elisp (frame-vars (sldb-get-frame frame)))) +(define (swank:frame-locals-and-catch-tags _ frame) + (list (map frame-var>elisp (frame-vars (sldb-get-frame frame))) + '())) (define (frame-vars frame) (with-values (lambda () (stack-frame/debugging-info frame)) From heller at common-lisp.net Tue Oct 21 20:37:51 2008 From: heller at common-lisp.net (CVS User heller) Date: Tue, 21 Oct 2008 20:37:51 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv23533 Modified Files: ChangeLog slime.el Log Message: * slime.el: Require some packages, e.g. apropos, at compile time to suppress some "undefined function" warnings. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/19 20:03:34 1.1566 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/21 20:37:51 1.1567 @@ -1,3 +1,8 @@ +2008-10-20 Helmut Eller + + * slime.el: Require some packages, apropos, at compile time to + suppress some "undefined function" warnings. + 2008-10-19 Helmut Eller * swank.lisp (frame-locals-and-catch-tags): New function. --- /project/slime/cvsroot/slime/slime.el 2008/10/19 20:03:34 1.1050 +++ /project/slime/cvsroot/slime/slime.el 2008/10/21 20:37:51 1.1051 @@ -64,6 +64,20 @@ (when (featurep 'xemacs) (require 'overlay)) (require 'easymenu) +(eval-when-compile + (require 'arc-mode) + (require 'apropos) + (require 'outline) + (require 'etags)) + +(eval-and-compile + (defvar slime-path + (let ((path (or (locate-library "slime") load-file-name))) + (and path (file-name-directory path))) + "Directory containing the Slime package. +This is used to load the supporting Common Lisp library, Swank. +The default value is automatically computed from the location of the +Emacs Lisp package.")) (defvar slime-lisp-modes '(lisp-mode)) @@ -85,15 +99,6 @@ (set (make-local-variable 'lisp-indent-function) 'common-lisp-indent-function)) -(eval-and-compile - (defvar slime-path - (let ((path (or (locate-library "slime") load-file-name))) - (and path (file-name-directory path))) - "Directory containing the Slime package. -This is used to load the supporting Common Lisp library, Swank. -The default value is automatically computed from the location of the -Emacs Lisp package.")) - (eval-and-compile (defun slime-changelog-date () "Return the datestring of the latest entry in the ChangeLog file. @@ -4549,7 +4554,6 @@ (file-name-directory guessed-target)) (file-name-nondirectory target-filename))))))) - (defun slime-goto-location-buffer (buffer) (flet ((file-truename-safe (filename) (and filename (file-truename filename)))) (destructure-case buffer @@ -5958,8 +5962,6 @@ (set-syntax-table lisp-mode-syntax-table) (goto-char (point-min))))) -(eval-when-compile (require 'apropos)) - (defvar slime-apropos-label-properties (progn (require 'apropos) From heller at common-lisp.net Tue Oct 21 20:37:56 2008 From: heller at common-lisp.net (CVS User heller) Date: Tue, 21 Oct 2008 20:37:56 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv23601/contrib Modified Files: ChangeLog slime-editing-commands.el Log Message: * slime-editing-commands.el (slime-end-of-defun): Use 'major-mode instead of 'major. Reported by S.P.Tseng. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/19 20:03:55 1.134 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/21 20:37:56 1.135 @@ -1,3 +1,8 @@ +2008-10-21 Helmut Eller + + * slime-editing-commands.el (slime-end-of-defun): Use 'major-mode + instead of 'major. Reported by S.P.Tseng. + 2008-10-19 Helmut Eller * swank-mit-scheme.scm (swank:frame-locals-and-catch-tags) --- /project/slime/cvsroot/slime/contrib/slime-editing-commands.el 2008/09/22 20:34:25 1.8 +++ /project/slime/cvsroot/slime/contrib/slime-editing-commands.el 2008/10/21 20:37:56 1.9 @@ -25,7 +25,7 @@ (defun slime-end-of-defun () (interactive) - (if (eq major 'slime-repl-mode) + (if (eq major-mode 'slime-repl-mode) (slime-repl-end-of-defun) (end-of-defun))) From heller at common-lisp.net Tue Oct 21 20:38:05 2008 From: heller at common-lisp.net (CVS User heller) Date: Tue, 21 Oct 2008 20:38:05 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv23660 Modified Files: ChangeLog swank-allegro.lisp Log Message: * swank-allegro.lisp (frame-restartable-p): Handle errors signaled by debugger:frame-retryable-p. This looks like an Allegro bug, though. Reported by Luke Hope. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/21 20:37:51 1.1567 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/21 20:38:05 1.1568 @@ -1,7 +1,13 @@ +2008-10-21 Helmut Eller + + * swank-allegro.lisp (frame-restartable-p): Handle errors signaled + by debugger:frame-retryable-p. This looks like an Allegro + bug, though. Reported by Luke Hope. + 2008-10-20 Helmut Eller - * slime.el: Require some packages, apropos, at compile time to - suppress some "undefined function" warnings. + * slime.el: Require some packages, e.g. apropos, at compile time + to suppress some "undefined function" warnings. 2008-10-19 Helmut Eller --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/19 20:03:34 1.118 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/10/21 20:38:05 1.119 @@ -207,7 +207,11 @@ (debugger:environment-of-frame frame))))) (defimplementation frame-restartable-p (frame) - (debugger:frame-retryable-p frame)) + (handler-case (debugger:frame-retryable-p frame) + (serious-condition (c) + (funcall (read-from-string "swank::background-message") + "~a ~a" frame (princ-to-string c)) + nil))) (defimplementation restart-frame (frame-number) (let ((frame (nth-frame frame-number))) From heller at common-lisp.net Thu Oct 23 21:28:03 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 23 Oct 2008 21:28:03 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv21347/contrib Modified Files: ChangeLog swank-asdf.lisp Log Message: * swank-asdf.lisp (operate-on-system-for-emacs): Always T to collect-notes. Reported by Mark Evenson. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/21 20:37:56 1.135 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/23 21:28:03 1.136 @@ -1,3 +1,8 @@ +2008-10-23 Helmut Eller + + * swank-asdf.lisp (operate-on-system-for-emacs): Always T to + collect-notes. Reported by Mark Evenson. + 2008-10-21 Helmut Eller * slime-editing-commands.el (slime-end-of-defun): Use 'major-mode --- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2008/10/04 19:13:42 1.6 +++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp 2008/10/23 21:28:03 1.7 @@ -17,7 +17,8 @@ Record compiler notes signalled as `compiler-condition's." (collect-notes (lambda () - (apply #'operate-on-system system-name operation keywords)))) + (apply #'operate-on-system system-name operation keywords) + t))) (defun operate-on-system (system-name operation-name &rest keyword-args) "Perform OPERATION-NAME on SYSTEM-NAME using ASDF. From heller at common-lisp.net Thu Oct 23 21:28:12 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 23 Oct 2008 21:28:12 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv21389 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-redirect-inferior-output): New command. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/21 20:38:05 1.1568 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/23 21:28:12 1.1569 @@ -1,3 +1,7 @@ +2008-10-23 Helmut Eller + + * slime.el (slime-redirect-inferior-output): New command. + 2008-10-21 Helmut Eller * swank-allegro.lisp (frame-restartable-p): Handle errors signaled --- /project/slime/cvsroot/slime/slime.el 2008/10/21 20:37:51 1.1051 +++ /project/slime/cvsroot/slime/slime.el 2008/10/23 21:28:12 1.1052 @@ -3816,6 +3816,25 @@ (switch-to-buffer buffer) (goto-char (point-max)))) +(defun slime-redirect-inferior-output (&optional noerror) + "Redirect output of the inferior-process to the REPL buffer." + (interactive) + (let ((proc (slime-inferior-process))) + (cond (proc + (let ((filter (slime-rcurry #'slime-inferior-output-filter + (slime-current-connection)))) + (set-process-filter proc filter))) + (noerror) + (t (error "No inferior lisp process"))))) + +(defun slime-inferior-output-filter (proc string conn) + (cond ((eq (process-status conn) 'closed) + (message "Connection closed. Removing inferior output filter.") + (message "Lost output: %S" string) + (set-process-filter proc nil)) + (t + (slime-output-filter conn string)))) + ;;;;; Cleanup after a quit From heller at common-lisp.net Thu Oct 23 21:33:53 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 23 Oct 2008 21:33:53 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv22327 Modified Files: ChangeLog Added Files: swank-jolt.k Log Message: * swank-jolt.k: New backend. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/23 21:28:03 1.136 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/23 21:33:49 1.137 @@ -1,5 +1,8 @@ 2008-10-23 Helmut Eller + * swank-jolt.k: New backend. + +2008-10-23 Helmut Eller * swank-asdf.lisp (operate-on-system-for-emacs): Always T to collect-notes. Reported by Mark Evenson. --- /project/slime/cvsroot/slime/contrib/swank-jolt.k 2008/10/23 21:33:54 NONE +++ /project/slime/cvsroot/slime/contrib/swank-jolt.k 2008/10/23 21:33:54 1.1 ;;; swank-jolt.k --- Swank server for Jolt -*- goo -*- ;; ;; Copyright (C) 2008 Helmut Eller ;; ;; This file is licensed under the terms of the GNU General Public ;; License as distributed with Emacs (press C-h C-c for details). ;;; Commentary: ;; ;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of ;; C, i.e. most objects are machine words and memory pointers. The ;; standard boot files define an interface to Id Smalltalk. So we can ;; also pretend to do OOP, but we must be careful to pass properly ;; tagged pointers to Smalltalk. ;; ;; This file only implements a minimum of SLIME's functionality. We ;; install a handler with atexit(3) to invoke the debugger. This way ;; we can stop Jolt from terminating the process on every error. ;; Unfortunately, the backtrace doesn't contain much information and ;; we also have no error message (other than the exit code). Jolt ;; usually prints some message to stdout before calling exit, so you ;; have to look in the *inferior-lisp* buffer for hints. We do ;; nothing (yet) to recover from SIGSEGV. ;;; Installation ;; ;; 1. Download and build cola. See . ;; I used the svn version: ;; svn co http://piumarta.com/svn2/idst/trunk idst ;; 2. Add something like this to your .emacs: ;; ;; (add-to-list 'slime-lisp-implementations ;; '(jolt (".../idst/function/jolt-burg/main" ;; "boot.k" ".../swank-jolt.k" "-") ; note the "-" ;; :init jolt-slime-init ;; :init-function slime-redirect-inferior-output) ;; (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file))) ;; (defun jolt () (interactive) (slime 'jolt)) ;; ;; 3. Use `M-x jolt' to start it. ;; ;;; Code ;; In this file I use 2-3 letters for often used names, like DF or ;; VEC, even if those names are abbreviations. I think that after a ;; little getting used to, this style is just as readable as the more ;; traditional DEFUN and VECTOR. Shorter names make it easier to ;; write terse code, in particular 1-line definitions. ;; `df' is like `defun' in a traditional lisp (syntax df (lambda (form compiler) (printf "df %s ...\n" [[[form second] asString] _stringValue]) `(define ,[form second] (lambda ,@[form copyFrom: '2])))) ;; (! args ...) is the same as [args ...] but easier to edit. (syntax ! (lambda (form compiler) (cond ((== [form size] '3) (if [[form third] isSymbol] `(send ',[form third] ,[form second]) [compiler errorSyntax: [form third]])) ((and [[form size] > '3] (== [[form size] \\ '2] '0)) (let ((args [OrderedCollection new]) (keys [OrderedCollection new]) (i '2) (len [form size])) (while (< i len) (let ((key [form at: i])) (if (or [key isKeyword] (and (== i '2) [key isSymbol])) ; for [X + Y] [keys addLast: [key asString]] [compiler errorSyntax: key])) [args addLast: [form at: [i + '1]]] (set i [i + '2])) `(send ',[[keys concatenated] asSymbol] ,[form second] , at args))) (1 [compiler errorArgumentCount: form])))) (define Integer (import "Integer")) (define Symbol (import "Symbol")) ;; aka. _selector (define StaticBlockClosure (import "StaticBlockClosure")) (define BlockClosure (import "BlockClosure")) (define SequenceableCollection (import "SequenceableCollection")) (define _vtable (import "_vtable")) (define ByteArray (import "ByteArray")) (define CodeGenerator (import "CodeGenerator")) (define TheGlobalEnvironment (import "TheGlobalEnvironment")) (df error (msg) (! Object error: msg)) (df print-to-string (obj) (let ((len '200) (stream (! WriteStream on: (! String new: len)))) (! stream print: obj) (! stream contents))) (df assertion-failed (exp) (error (! '"Assertion failed: " , (print-to-string exp)))) (syntax assert (lambda (form) `(if (not ,(! form second)) (assertion-failed ',(! form second))))) (df isa? (obj type) (! obj isKindOf: type)) (df equal (o1 o2) (! o1 = o2)) (define nil 0) (define false 0) (define true (! Object notNil)) (df bool? (obj) (or (== obj false) (== obj true))) (df int? (obj) (isa? obj Integer)) ;; In this file the convention X>Y is used for operations that convert ;; X-to-Y. And _ means "machine word". So _>int is the operator that ;; converts a machine word to an Integer. (df _>int (word) (! Integer value_: word)) (df int>_ (i) (! i _integerValue)) ;; Fixnum operators. Manual tagging/untagging would probably be ;; efficent than invoking methods (df fix? (obj) (& obj 1)) (df _>fix (n) (! SmallInteger value_: n)) (df fix>_ (i) (! i _integerValue)) (df fx+ (fx1 fx2) (! fx1 + fx2)) (df fx* (fx1 fx2) (! fx1 * fx2)) (df fx1+ (fx) (! fx + '1)) (df fx1- (fx) (! fx - '1)) (df str? (obj) (isa? obj String)) (df >str (o) (! o asString)) (df str>_ (s) (! s _stringValue)) (df _>str (s) (! String value_: s)) (df sym? (obj) (isa? obj Symbol)) (df seq? (obj) (isa? obj SequenceableCollection)) (df array? (obj) (isa? obj Array)) (df len (obj) (! obj size)) (df len_ (obj) (! (! obj size) _integerValue)) (df ref (obj idx) (! obj at: idx)) (df set-ref (obj idx elt) (! obj at: idx put: elt)) (df first (obj) (! obj first)) (df second (obj) (! obj second)) (df puts (string stream) (! stream nextPutAll: string)) (define _GC_base (dlsym "GC_base")) ;; Is ADDR a pointer to a heap allocated object? The Boehm GC nows ;; such things. This is useful for debugging, because we can quite ;; safely (i.e. without provoking SIGSEGV) access such addresses. (df valid-pointer? (addr) (let ((ptr (& addr (~ 1)))) (and (_GC_base ptr) (_GC_base (long@ ptr -1))))) ;; Print OBJ as a Lisp printer would do. (df prin1 (obj stream) (cond ((fix? obj) (! stream print: obj)) ((== obj nil) (puts '"nil" stream)) ((== obj false) (puts '"#f" stream)) ((== obj true) (puts '"#t" stream)) ((not (valid-pointer? obj)) (begin (puts '"#int obj) stream) (puts '">" stream))) ((int? obj) (! stream print: obj)) ((sym? obj) (puts (>str obj) stream)) ((isa? obj StaticBlockClosure) (begin (puts '"#" stream))) ((and (str? obj) (len obj)) (! obj printEscapedOn: stream delimited: (ref '"\"" '0))) ((and (array? obj) (len obj)) (begin (puts '"(" stream) (let ((max (- (len_ obj) 1))) (for (i 0 1 max) (prin1 (ref obj (_>fix i)) stream) (if (!= i max) (puts '" " stream)))) (puts '")" stream))) ((and (isa? obj OrderedCollection) (len obj)) (begin (puts '"#[" stream) (let ((max (- (len_ obj) 1))) (for (i 0 1 max) (prin1 (ref obj (_>fix i)) stream) (if (!= i max) (puts '" " stream)))) (puts '"]" stream))) (true (begin (puts '"#<" stream) (puts (! obj debugName) stream) (puts '">" stream)))) obj) (df print (obj) (prin1 obj StdOut) (puts '"\n" StdOut)) (df prin1-to-string (obj) (let ((len '100) (stream (! WriteStream on: (! String new: len)))) (prin1 obj stream) (! stream contents))) ;;(df %vable-tally (_vtable) (long@ _vtable)) (df cr () (printf "\n")) (df print-object-selectors (obj) (let ((vtable (! obj _vtable)) (tally (long@ vtable 0)) (bindings (long@ vtable 1))) (for (i 1 1 tally) (print (long@ (long@ bindings i))) (cr)))) (df print-object-slots (obj) (let ((size (! obj _sizeof)) (end (+ obj size))) (while (< obj end) (print (long@ obj)) (cr) (incr obj 4)))) (df intern (string) (! Symbol intern: string)) ;; Jolt doesn't seem to have an equivalent for gensym, but it's damn ;; hard to write macros without it. So here we adopt the conventions ;; that symbols which look like ".[0-9]+" are reserved for gensym and ;; shouldn't be used for "user visible variables". (define gensym-counter 0) (df gensym () (set gensym-counter (+ gensym-counter 1)) (intern (! '"." , (>str (_>fix gensym-counter))))) ;; Surprisingly, SequenceableCollection doesn't have a indexOf method. ;; So we even need to implement such mundane things. (df index-of (seq elt) (let ((max (len seq)) (i '0)) (while (! i < max) (if (equal (ref seq i) elt) (return i) (set i (! i + '1)))) nil)) (df find-dot (array) (index-of array '.)) ;; What followes is the implementation of the pattern matching macro MIF. ;; The syntax is (mif (PATTERN EXP) THEN ELSE). ;; The THEN-branch is executed if PATTERN matches the value produced by EXP. ;; ELSE gets only executed if the match failes. ;; A pattern can be ;; 1) a symbol, which matches all values, but also binds the variable to the ;; value ;; 2) (quote LITERAL), matches if the value is `equal' to LITERAL. ;; 3) (PS ...) matches sequences, if the elements match PS. ;; 4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements ;; at indices 1..n and if Ptail matches the rest ;; of the sequence ;; Examples: ;; (mif (x 10) x 'else) => 10 ;; (mif ('a 'a) 'then 'else) => then ;; (mif ('a 'b) 'then 'else) => else ;; (mif ((a b) '(1 2)) b 'else) => 2 ;; (mif ((a . b) '(1 2)) b 'else) => '(2) ;; (mif ((. x) '(1 2)) x 'else) => '(1 2) (define mif% 0) ;; defer (df mif%array (compiler pattern i value then fail) ;;(print `(mif%array ,pattern ,i ,value)) (cond ((== i (len_ pattern)) then) ((== (ref pattern (_>fix i)) '.) (begin (if (!= (- (len_ pattern) 2) i) (begin (print pattern) (! compiler error: (! '"dot in strange position: " , (>str (_>fix i)))))) (mif% compiler (ref pattern (_>fix (+ i 1))) `(! ,value copyFrom: ',(_>fix i)) then fail))) (true (mif% compiler (ref pattern (_>fix i)) `(ref ,value ',(_>fix i)) (mif%array compiler pattern (+ i 1) value then fail) fail)))) (df mif% (compiler pattern value then fail) ;;(print `(mif% ,pattern ,value ,then)) (cond ((== pattern '_) then) ((== pattern '.) (! compiler errorSyntax: pattern)) ((sym? pattern) `(let ((,pattern ,value)) ,then)) ((seq? pattern) (cond ((== (len_ pattern) 0) `(if (== (len_ ,value) 0) ,then (goto ,fail))) ((== (first pattern) 'quote) (begin (if (not (== (len_ pattern) 2)) (! compiler errorSyntax: pattern)) `(if (equal ,value ,pattern) ,then (goto ,fail)))) (true (let ((tmp (gensym)) (tmp2 (gensym)) (pos (find-dot pattern))) `(let ((,tmp2 ,value) (,tmp ,tmp2)) (if (and (seq? ,tmp) ,(if (find-dot pattern) `(>= (len ,tmp) ',(_>fix (- (len_ pattern) 2))) `(== (len ,tmp) ',(len pattern)))) ,(mif%array compiler pattern 0 tmp then fail) (goto ,fail))))))) (true (! compiler errorSyntax: pattern)))) (syntax mif (lambda (node compiler) ;;(print `(mif ,node)) (if (not (or (== (len_ node) 4) (== (len_ node) 3))) (! compiler errorArgumentCount: node)) (if (not (and (array? (ref node '1)) (== (len_ (ref node '1)) 2))) (! compiler errorSyntax: (ref node '1))) (let ((pattern (first (ref node '1))) (value (second (ref node '1))) (then (ref node '2)) (else (if (== (len_ node) 4) (ref node '3) `(error "mif failed"))) (destination (gensym)) (fail (! compiler newLabel)) (success (! compiler newLabel))) `(let ((,destination 0)) ,(mif% compiler pattern value `(begin (set ,destination ,then) (goto ,success)) fail) (label ,fail) (set ,destination ,else) (label ,success) ,destination)))) ;; (define *catch-stack* nil) ;; (df bar (o) (mif ('a o) 'yes 'no)) (assert (== (bar 'a) 'yes)) (assert (== (bar 'b) 'no)) (df foo (o) (mif (('a) o) 'yes 'no)) (assert (== (foo '(a)) 'yes)) (assert (== (foo '(b)) 'no)) (df baz (o) (mif (('a 'b) o) 'yes 'no)) (assert (== (baz '(a b)) 'yes)) (assert (== (baz '(a c)) 'no)) (assert (== (baz '(b c)) 'no)) (assert (== (baz 'a) 'no)) (df mifvar (o) (mif (y o) y 'no)) (assert (== (mifvar 'foo) 'foo)) (df mifvec (o) (mif ((y) o) y 'no)) (assert (== (mifvec '(a)) 'a)) (assert (== (mifvec 'x) 'no)) (df mifvec2 (o) (mif (('a y) o) y 'no)) (assert (== (mifvec2 '(a b)) 'b)) (assert (== (mifvec2 '(b c)) 'no)) (assert (== (mif ((x) '(a)) x 'no) 'a)) (assert (== (mif ((x . y) '(a b)) x 'no) 'a)) (assert (== (mif ((x y . z) '(a b)) y 'no) 'b)) (assert (equal (mif ((x . y) '(a b)) y 'no) '(b))) (assert (equal (mif ((. x) '(a b)) x 'no) '(a b))) (assert (equal (mif (((. x)) '((a b))) x 'no) '(a b))) (assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c))) (assert (== (mif (() '()) 'yes 'no) 'yes)) (assert (== (mif (() '(a)) 'yes 'no) 'no)) ;; Now that we have a somewhat convenient pattern matcher we can write ;; a more convenient macro defining macro: (syntax defmacro (lambda (node compiler) (mif (('defmacro name (. args) . body) node) (begin (printf "defmacro %s ...\n" (str>_ (>str name))) `(syntax ,name (lambda (node compiler) (mif ((',name , at args) node) (begin , at body) (! compiler errorSyntax: node))))) [608 lines skipped] From heller at common-lisp.net Sun Oct 26 21:17:44 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 26 Oct 2008 21:17:44 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv19923 Modified Files: ChangeLog slime.el Log Message: * slime.el: Fix change from 2008-10-20. Use (eval-when (compile)...) instead of (eval-when-compile ...), because the latter is more like (eval-when (compile eval) ...). --- /project/slime/cvsroot/slime/ChangeLog 2008/10/23 21:28:12 1.1569 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/26 21:17:44 1.1570 @@ -1,3 +1,9 @@ +2008-10-26 Helmut Eller + + * slime.el: Fix change from 2008-10-20. + Use (eval-when (compile)...) instead of (eval-when-compile ...), + because the latter is more like (eval-when (compile eval) ...). + 2008-10-23 Helmut Eller * slime.el (slime-redirect-inferior-output): New command. --- /project/slime/cvsroot/slime/slime.el 2008/10/23 21:28:12 1.1052 +++ /project/slime/cvsroot/slime/slime.el 2008/10/26 21:17:44 1.1053 @@ -64,7 +64,7 @@ (when (featurep 'xemacs) (require 'overlay)) (require 'easymenu) -(eval-when-compile +(eval-when (compile) (require 'arc-mode) (require 'apropos) (require 'outline) From heller at common-lisp.net Sun Oct 26 21:17:58 2008 From: heller at common-lisp.net (CVS User heller) Date: Sun, 26 Oct 2008 21:17:58 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv20007 Modified Files: ChangeLog test.sh Log Message: * test.sh: Return the number of failed tests as exit code. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/26 21:17:44 1.1570 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/26 21:17:58 1.1571 @@ -1,5 +1,7 @@ 2008-10-26 Helmut Eller + * test.sh: Return the number of failed tests as exit code. + * slime.el: Fix change from 2008-10-20. Use (eval-when (compile)...) instead of (eval-when-compile ...), because the latter is more like (eval-when (compile eval) ...). --- /project/slime/cvsroot/slime/test.sh 2008/09/20 21:46:23 1.20 +++ /project/slime/cvsroot/slime/test.sh 2008/10/26 21:17:58 1.21 @@ -87,16 +87,18 @@ screen -S $session -m -D \ bash -c "\"\$@\"; echo \$? > $statusfile" "" "${cmd[@]}" & screenpid=$! - trap "screen -S $session -X quit" SIGINT + trap "screen -S $session -X quit" SIGINT SIGQUIT wait $screenpid fi if [ -f "$statusfile" ]; then - [ "$dump_results" = true ] && cat $results; - echo $(cat $statusfile) "test(s) failed." + [ "$dump_results" = true ] && cat $results + status=$(cat $statusfile) + echo $status "test(s) failed." else # Tests crashed echo crashed + status=255 fi exit $status From heller at common-lisp.net Thu Oct 30 09:28:21 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 30 Oct 2008 09:28:21 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv20263/contrib Modified Files: ChangeLog swank-listener-hooks.lisp Log Message: * swank-listener-hooks.lisp (%listener-eval): Return nil. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/23 21:33:49 1.137 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/30 09:28:21 1.138 @@ -1,3 +1,7 @@ +2008-10-30 Ivan Shvedunov + + * swank-listener-hooks.lisp (%listener-eval): Return nil. + 2008-10-23 Helmut Eller * swank-jolt.k: New backend. --- /project/slime/cvsroot/slime/contrib/swank-listener-hooks.lisp 2008/08/22 21:15:01 1.2 +++ /project/slime/cvsroot/slime/contrib/swank-listener-hooks.lisp 2008/10/30 09:28:21 1.3 @@ -77,7 +77,8 @@ /// // // / / values)) (setq +++ ++ ++ + + last-form) (unless (eq *slime-repl-suppress-output* t) - (funcall *send-repl-results-function* values)))))))) + (funcall *send-repl-results-function* values))))))) + nil) (setq *listener-eval-function* '%listener-eval) From heller at common-lisp.net Thu Oct 30 09:28:26 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 30 Oct 2008 09:28:26 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv20297/contrib Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/30 09:28:21 1.138 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/30 09:28:25 1.139 @@ -1,4 +1,4 @@ -2008-10-30 Ivan Shvedunov +2008-10-30 Ivan Shvedunov * swank-listener-hooks.lisp (%listener-eval): Return nil. From heller at common-lisp.net Thu Oct 30 09:28:35 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 30 Oct 2008 09:28:35 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv20344 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-repl-history-pattern): Use the part of input between its start and (point) as history search pattern. Previously we used the entire input. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/26 21:17:58 1.1571 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/30 09:28:35 1.1572 @@ -1,3 +1,9 @@ +2008-10-30 Ivan Shvedunov + + * slime.el (slime-repl-history-pattern): Use the part of input + between its start and (point) as history search pattern. + Previously we used the entire input. + 2008-10-26 Helmut Eller * test.sh: Return the number of failed tests as exit code. --- /project/slime/cvsroot/slime/slime.el 2008/10/26 21:17:44 1.1053 +++ /project/slime/cvsroot/slime/slime.el 2008/10/30 09:28:35 1.1054 @@ -3403,7 +3403,9 @@ (cond ((slime-repl-history-search-in-progress-p) slime-repl-history-pattern) (use-current-input - (let ((str (slime-repl-current-input))) + (assert (<= slime-repl-input-start-mark (point))) + (let ((str (buffer-substring-no-properties + slime-repl-input-start-mark (point)))) (cond ((string-match "^[ \n]*$" str) nil) (t (concat "^" (regexp-quote str)))))) (t nil))) From heller at common-lisp.net Thu Oct 30 09:28:43 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 30 Oct 2008 09:28:43 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv20390 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-popup-buffer-quit): Call bury-buffer with explicit argument for compatibility with XEmacs. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/30 09:28:35 1.1572 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/30 09:28:43 1.1573 @@ -1,3 +1,8 @@ +2008-10-30 Helmut Eller + + * slime.el (slime-popup-buffer-quit): Call bury-buffer with + explicit argument for compatibility with XEmacs. + 2008-10-30 Ivan Shvedunov * slime.el (slime-repl-history-pattern): Use the part of input --- /project/slime/cvsroot/slime/slime.el 2008/10/30 09:28:35 1.1054 +++ /project/slime/cvsroot/slime/slime.el 2008/10/30 09:28:43 1.1055 @@ -1052,10 +1052,9 @@ (let ((buffer (current-buffer))) (when (slime-popup-buffer-snapshot-unchanged-p) (slime-popup-buffer-restore-snapshot)) - (with-current-buffer buffer - (setq slime-popup-buffer-saved-emacs-snapshot nil) ; buffer-local var! - (cond (kill-buffer-p (kill-buffer nil)) - (t (bury-buffer)))))) + (setq slime-popup-buffer-saved-emacs-snapshot nil) ; buffer-local var! + (cond (kill-buffer-p (kill-buffer buffer)) + (t (bury-buffer buffer))))) (defun slime-popup-buffer-snapshot-unchanged-p () (equalp (slime-current-emacs-snapshot-fingerprint) From heller at common-lisp.net Thu Oct 30 09:28:51 2008 From: heller at common-lisp.net (CVS User heller) Date: Thu, 30 Oct 2008 09:28:51 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv20453 Modified Files: ChangeLog swank-sbcl.lisp Log Message: * swank-sbcl.lisp (wait-for-input): Return streams which are at EOF. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/30 09:28:43 1.1573 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/30 09:28:51 1.1574 @@ -1,5 +1,10 @@ 2008-10-30 Helmut Eller + * swank-sbcl.lisp (wait-for-input): Return streams which are at + EOF. + +2008-10-30 Helmut Eller + * slime.el (slime-popup-buffer-quit): Call bury-buffer with explicit argument for compatibility with XEmacs. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/17 21:27:24 1.226 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/10/30 09:28:51 1.227 @@ -176,13 +176,22 @@ (setq *wait-for-input-called* t)) (let ((*wait-for-input-called* nil)) (loop - (let ((ready (remove-if-not #'listen streams))) + (let ((ready (remove-if (lambda (s) + (let ((c (read-char-no-hang s nil :eof))) + (case c + ((nil) t) + ((:eof) nil) + (t + (unread-char c s) + nil)))) + streams))) (when ready (return ready))) (when timeout (return nil)) (when (check-slime-interrupts) (return :interrupt)) (when *wait-for-input-called* (return :interrupt)) (let* ((f (constantly t)) (handlers (loop for s in streams + do (assert (open-stream-p s)) collect (add-one-shot-handler s f)))) (unwind-protect (sb-sys:serve-event 0.2) From nsiivola at common-lisp.net Fri Oct 31 13:52:16 2008 From: nsiivola at common-lisp.net (CVS User nsiivola) Date: Fri, 31 Oct 2008 13:52:16 +0000 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory cl-net:/tmp/cvs-serv19710/contrib Modified Files: ChangeLog swank-presentation-streams.lisp Log Message: delete references to SB-IMPL::INDENTING-STREAM delete references to SB-IMPL::INDENTING-STREAM --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/30 09:28:25 1.139 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/10/31 13:52:16 1.140 @@ -1,3 +1,9 @@ +2008-10-31 Nikodemus Siivola + + * swank-presentation-streams.liso (slime-stream-p): delete + references to SB-IMPL::INDENTING-STREAM, which is unused in SBCL + and liable to go away. + 2008-10-30 Ivan Shvedunov * swank-listener-hooks.lisp (%listener-eval): Return nil. --- /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2008/02/04 18:00:36 1.5 +++ /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2008/10/31 13:52:16 1.6 @@ -121,12 +121,10 @@ #+sbcl (let () (declare (notinline sb-pretty::pretty-stream-target)) - (or (and (typep stream 'sb-impl::indenting-stream) - (slime-stream-p (sb-impl::indenting-stream-stream stream))) - (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) - (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) - (not *use-dedicated-output-stream*) - (slime-stream-p (sb-pretty::pretty-stream-target stream))))) + (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) + (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) + (not *use-dedicated-output-stream*) + (slime-stream-p (sb-pretty::pretty-stream-target stream)))) #+allegro (and (typep stream 'excl:xp-simple-stream) (slime-stream-p (excl::stream-output-handle stream))) From heller at common-lisp.net Fri Oct 31 14:13:10 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 31 Oct 2008 14:13:10 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv23625 Modified Files: ChangeLog slime.el swank.lisp Log Message: * swank.lisp (debug-in-emacs): Bind *sldb-quit-restart* here, if necessary to the next abort retstart. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/30 09:28:51 1.1574 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/31 14:13:10 1.1575 @@ -1,3 +1,8 @@ +2008-10-31 Helmut Eller + + * swank.lisp (debug-in-emacs): Bind *sldb-quit-restart* + here, if necessary to the next abort retstart. + 2008-10-30 Helmut Eller * swank-sbcl.lisp (wait-for-input): Return streams which are at --- /project/slime/cvsroot/slime/slime.el 2008/10/30 09:28:43 1.1055 +++ /project/slime/cvsroot/slime/slime.el 2008/10/31 14:13:10 1.1056 @@ -9503,17 +9503,9 @@ (get-buffer-window (sldb-get-default-buffer)))) 5) (with-current-buffer (sldb-get-default-buffer) - (sldb-invoke-restart (slime-test-find-top-level-restart))) + (sldb-quit)) (slime-sync-to-top-level 5)) -(defun slime-test-find-top-level-restart () - (let ((case-fold-search t)) - (or (loop for i from 0 for (name str) in sldb-restarts - when (string-match "SLIME's top level" str) return i) - (loop for i from 0 for (name str) in sldb-restarts - when (and (string-match "abort" name) (string-match "top" str)) - return i)))) - (def-slime-test interrupt-in-blocking-read () "Let's see what happens if we interrupt a blocking read operation." @@ -9565,7 +9557,7 @@ (lambda () (equal (sldb-level) level)) 2))) (with-current-buffer (sldb-get-default-buffer) - (sldb-invoke-restart (slime-test-find-top-level-restart))) + (sldb-quit)) (slime-sync-to-top-level 1)) (def-slime-test disconnect --- /project/slime/cvsroot/slime/swank.lisp 2008/10/19 20:03:34 1.607 +++ /project/slime/cvsroot/slime/swank.lisp 2008/10/31 14:13:10 1.608 @@ -2197,6 +2197,9 @@ (defun debug-in-emacs (condition) (let ((*swank-debugger-condition* condition) (*sldb-restarts* (compute-restarts condition)) + (*sldb-quit-restart* (if (boundp '*sldb-quit-restart*) + *sldb-quit-restart* + (find-restart 'abort))) (*package* (or (and (boundp '*buffer-package*) (symbol-value '*buffer-package*)) *package*)) @@ -2355,12 +2358,9 @@ (defslimefun throw-to-toplevel () "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. If we are not evaluating an RPC then ABORT instead." - (let ((restart (and (not (symbolp *sldb-quit-restart*)) - (find-restart *sldb-quit-restart*)))) + (let ((restart (find-restart *sldb-quit-restart*))) (cond (restart (invoke-restart restart)) - (t (format nil - "Restart not found: ~a" - *sldb-quit-restart*))))) + (t "Toplevel restart found")))) (defslimefun invoke-nth-restart-for-emacs (sldb-level n) "Invoke the Nth available restart. From heller at common-lisp.net Fri Oct 31 14:13:19 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 31 Oct 2008 14:13:19 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv23696 Modified Files: ChangeLog swank-lispworks.lisp Log Message: * swank-lispworks.lisp (describe-function): Don't use string-upcase on lambda-list-argruments, because not all elements must be symbols. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/31 14:13:10 1.1575 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/31 14:13:19 1.1576 @@ -1,5 +1,11 @@ 2008-10-31 Helmut Eller + * swank-lispworks.lisp (describe-function): Don't use + string-upcase on lambda-list-argruments, because not all elements + must be symbols. + +2008-10-31 Helmut Eller + * swank.lisp (debug-in-emacs): Bind *sldb-quit-restart* here, if necessary to the next abort retstart. --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/19 20:03:34 1.122 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/10/31 14:13:19 1.123 @@ -217,10 +217,9 @@ (defun describe-function (symbol) (cond ((fboundp symbol) - (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%" - (string-downcase symbol) - (mapcar #'string-upcase - (lispworks:function-lambda-list symbol)) + (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" + symbol + (lispworks:function-lambda-list symbol) (documentation symbol 'function)) (describe (fdefinition symbol))) (t (format t "~S is not fbound" symbol)))) From heller at common-lisp.net Fri Oct 31 14:13:34 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 31 Oct 2008 14:13:34 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv23746 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-eval-with-transcript) (slime-eval-with-transcript-cont): Restore the current buffer, before calling cont. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/31 14:13:19 1.1576 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/31 14:13:34 1.1577 @@ -1,5 +1,11 @@ 2008-10-31 Helmut Eller + * slime.el (slime-eval-with-transcript) + (slime-eval-with-transcript-cont): Restore the current buffer, + before calling cont. + +2008-10-31 Helmut Eller + * swank-lispworks.lisp (describe-function): Don't use string-upcase on lambda-list-argruments, because not all elements must be symbols. --- /project/slime/cvsroot/slime/slime.el 2008/10/31 14:13:10 1.1056 +++ /project/slime/cvsroot/slime/slime.el 2008/10/31 14:13:34 1.1057 @@ -5404,9 +5404,9 @@ (when msg (slime-insert-transcript-delimiter msg)) (setq slime-repl-popup-on-output (not no-popups)) (setq cont (or cont #'slime-display-eval-result)) - (slime-rex (cont) (form) - ((:ok value) (slime-eval-with-transcript-cont t value cont)) - ((:abort) (slime-eval-with-transcript-cont nil nil nil)))) + (slime-rex (cont (buffer (current-buffer))) (form) + ((:ok value) (slime-eval-with-transcript-cont t value cont buffer)) + ((:abort) (slime-eval-with-transcript-cont nil nil nil buffer)))) (defun slime-insert-transcript-delimiter (string) (with-current-buffer (slime-output-buffer) @@ -5423,14 +5423,15 @@ (slime-mark-output-start)) (slime-repl-show-maximum-output))) -(defun slime-eval-with-transcript-cont (ok result cont) +(defun slime-eval-with-transcript-cont (ok result cont buffer) (run-with-timer 0.2 nil (lambda () (setq slime-repl-popup-on-output nil))) (with-current-buffer (slime-output-buffer) (save-excursion (slime-repl-insert-prompt)) - (slime-repl-show-maximum-output) + (slime-repl-show-maximum-output)) + (with-current-buffer buffer (cond (ok (funcall cont result)) - (t (message "Evaluation aborted."))))) + (t (message "Evaluation aborted."))))) (defun slime-eval-describe (form) "Evaluate FORM in Lisp and display the result in a new buffer." From heller at common-lisp.net Fri Oct 31 14:19:35 2008 From: heller at common-lisp.net (CVS User heller) Date: Fri, 31 Oct 2008 14:19:35 +0000 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory cl-net:/tmp/cvs-serv24250 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-repl-history-pattern): Simplify as suggested by Knut Olav Bohmer and Michael Weber. --- /project/slime/cvsroot/slime/ChangeLog 2008/10/31 14:13:34 1.1577 +++ /project/slime/cvsroot/slime/ChangeLog 2008/10/31 14:19:35 1.1578 @@ -1,5 +1,10 @@ 2008-10-31 Helmut Eller + * slime.el (slime-repl-history-pattern): Simplify as suggested by + Knut Olav B?hmer and Michael Weber. + +2008-10-31 Helmut Eller + * slime.el (slime-eval-with-transcript) (slime-eval-with-transcript-cont): Restore the current buffer, before calling cont. @@ -12,8 +17,8 @@ 2008-10-31 Helmut Eller - * swank.lisp (debug-in-emacs): Bind *sldb-quit-restart* - here, if necessary to the next abort retstart. + * swank.lisp (debug-in-emacs): Bind *sldb-quit-restart* here. If + necessary, use the current abort retstart. 2008-10-30 Helmut Eller --- /project/slime/cvsroot/slime/slime.el 2008/10/31 14:13:34 1.1057 +++ /project/slime/cvsroot/slime/slime.el 2008/10/31 14:19:35 1.1058 @@ -2978,11 +2978,10 @@ buffer." (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks until-point-p) - (buffer-substring-no-properties - slime-repl-input-start-mark - (if until-point-p - (point) - (point-max))))) + (buffer-substring-no-properties slime-repl-input-start-mark + (if until-point-p + (point) + (point-max))))) (defun slime-property-position (text-property &optional object) "Return the first position of TEXT-PROPERTY, or nil." @@ -3403,8 +3402,7 @@ slime-repl-history-pattern) (use-current-input (assert (<= slime-repl-input-start-mark (point))) - (let ((str (buffer-substring-no-properties - slime-repl-input-start-mark (point)))) + (let ((str (slime-repl-current-input t))) (cond ((string-match "^[ \n]*$" str) nil) (t (concat "^" (regexp-quote str)))))) (t nil)))