Index: swank-loader.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-loader.lisp,v retrieving revision 1.75 diff -u -r1.75 swank-loader.lisp --- swank-loader.lisp 24 Nov 2007 08:18:59 -0000 1.75 +++ swank-loader.lisp 2 Feb 2008 20:12:37 -0000 @@ -60,14 +67,9 @@ :sparc64 :sparc :hppa64 :hppa)) (defun lisp-version-string () - #+cmu (substitute-if #\_ (lambda (x) (find x " /")) + #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /")) (lisp-implementation-version)) - #+scl (lisp-implementation-version) - #+sbcl (lisp-implementation-version) - #+ecl (lisp-implementation-version) - #+openmcl (format nil "~d.~d" - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version*) + #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version) #+lispworks (lisp-implementation-version) #+allegro (format nil "~A~A~A" @@ -76,8 +78,7 @@ (if (member :64bit *features*) "-64bit" "")) #+clisp (let ((s (lisp-implementation-version))) (subseq s 0 (position #\space s))) - #+armedbear (lisp-implementation-version) - #+cormanlisp (lisp-implementation-version)) + #+armedbear (lisp-implementation-version)) (defun unique-directory-name () "Return a name that can be used as a directory name that is Index: swank-openmcl.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-openmcl.lisp,v retrieving revision 1.120 diff -u -r1.120 swank-openmcl.lisp --- swank-openmcl.lisp 22 Oct 2007 08:19:58 -0000 1.120 +++ swank-openmcl.lisp 2 Feb 2008 20:12:37 -0000 @@ -211,14 +211,18 @@ (defvar *break-in-sldb* t) + (let ((ccl::*warn-if-redefine-kernel* nil)) - (ccl::advise - cl::break + (ccl::advise + ccl::cbreak-loop (if (and *break-in-sldb* - (find ccl::*current-process* (symbol-value (intern "*CONNECTIONS*" 'swank)) - :key (intern "CONNECTION.REPL-THREAD" 'swank))) + (find ccl::*current-process* + (symbol-value (intern (string :*connections*) :swank)) + :key (intern (string :connection.repl-thread) :swank))) (apply 'break-in-sldb ccl::arglist) - (:do-it)) :when :around :name sldb-break)) + (:do-it)) + :when :around + :name sldb-break)) (defun break-in-sldb (&optional string &rest args) (let ((c (make-condition 'simple-condition @@ -279,6 +283,7 @@ (defvar *buffer-offset* nil) (defvar *buffer-name* nil) +(defvar *buffer-directory* nil) (defun condition-source-position (condition) "Return the position in the source file of a compiler condition." @@ -319,7 +324,8 @@ (declare (ignore external-format)) (with-compilation-hooks () (let ((*buffer-name* nil) - (*buffer-offset* nil)) + (*buffer-offset* nil) + (*buffer-directory* nil)) (compile-file filename :load load-p)))) (defimplementation frame-var-value (frame var) @@ -335,8 +341,7 @@ for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp)) when name do (incf varcount) until (= varcount var) - finally (return value)) - ))))))) + finally (return value))))))))) (defun xref-locations (relation name &optional (inverse nil)) (flet ((function-source-location (entry) @@ -366,7 +371,7 @@ (ccl::method-qualifiers (caar info)))) nil)) (t - (canonicalize-location (cdr (first info)) name)))))) + (canonicalize-location (cdr (first info)) name nil)))))) (declare (dynamic-extent #'function-source-location)) (loop for xref in (if inverse (ccl::get-relation relation name @@ -424,10 +429,10 @@ :test 'equal)) (defimplementation swank-compile-string (string &key buffer position directory) - (declare (ignore directory)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-offset* position) + (*buffer-directory* directory) (filename (temp-file-name))) (unwind-protect (with-open-file (s filename :direction :output :if-exists :error) @@ -466,7 +471,8 @@ (setq ccl::*fasl-save-definitions* nil) (setq ccl::*fasl-save-doc-strings* t) (setq ccl::*fasl-save-local-symbols* t) - (setq ccl::*ppc2-compiler-register-save-label* t) + #+ppc (setq ccl::*ppc2-compiler-register-save-label* t) + #+x86-64 (setq ccl::*x862-compiler-register-save-label* t) (setq ccl::*save-arglist-info* t) (setq ccl::*save-definitions* nil) (setq ccl::*save-doc-strings* t) @@ -513,9 +519,8 @@ (defun frame-arguments (p context lfun pc) "Returns a string representing the arguments of a frame." - (multiple-value-bind (args types names count nclosed) + (multiple-value-bind (args types names) (ccl::frame-supplied-args p lfun pc nil context) - (declare (ignore count nclosed)) (let ((result nil)) (loop named loop for var = (cond @@ -575,7 +580,9 @@ (push (list :name name :id 0 - :value var) + :value (if (typep var 'ccl::value-cell) + (ccl::uvref var 0) + var)) result)))) (return-from frame-locals (nreverse result))))))))) @@ -610,19 +617,24 @@ (when (= frame-number the-frame-number) (setq function-to-disassemble lfun) (return-from find-frame))))) - (ccl::print-ppc-instructions - *standard-output* - (ccl::function-to-dll-header function-to-disassemble) nil))) + #+ppc (ccl::print-ppc-instructions + *standard-output* + (ccl::function-to-dll-header function-to-disassemble) + nil) + #+x86-64 (ccl::x8664-xdisassemble function-to-disassemble))) ;;; -(defun canonicalize-location (file symbol) +(defun canonicalize-location (file symbol snippet) (etypecase file ((or string pathname) (multiple-value-bind (truename c) (ignore-errors (namestring (truename file))) (cond (c (list :error (princ-to-string c))) (t (make-location (list :file (remove-filename-quoting truename)) - (list :function-name (princ-to-string symbol))))))))) + (list :function-name (princ-to-string symbol)) + (if snippet + (list :snippet snippet) + '())))))))) (defun remove-filename-quoting (string) (if (search "\\" string) @@ -642,22 +654,22 @@ when (not (equal "l1-boot-3" (pathname-name file))) ; alanr: This is a bug - there's nothing in there collect (or (maybe-method-location type) (list (list type symbol) - (canonicalize-location file symbol)))))) - + (canonicalize-location file symbol nil)))))) (defun function-source-location (function) - (multiple-value-bind (info name) (ccl::edit-definition-p function) + (multiple-value-bind (info name) + (ccl::edit-definition-p function) (cond ((not info) (list :error (format nil "No source info available for ~A" function))) ((typep (caar info) 'ccl::method) `(:location (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) ))) (:method ,(princ-to-string (ccl::method-name (caar info))) - ,(mapcar 'princ-to-string - (mapcar #'specializer-name - (ccl::method-specializers (caar info)))) - ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers (caar info)))) + ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) nil)) - (t (canonicalize-location (cdr (first info)) name))))) + (t (canonicalize-location (second (first info)) name (third (first info))))))) (defimplementation frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the @@ -693,6 +705,7 @@ ,form))) ))))))) +#+ppc (defimplementation return-from-frame (index form) (let ((values (multiple-value-list (eval-in-frame form index)))) (map-backtrace @@ -700,7 +713,8 @@ (declare (ignore context lfun pc)) (when (= frame-number index) (ccl::apply-in-frame p #'values values)))))) - + +#+ppc (defimplementation restart-frame (index) (map-backtrace (lambda (frame-number p context lfun pc) @@ -769,7 +783,7 @@ name `(,type ,name ,specializers ,@modifiers)) - (canonicalize-location file name)))))) + (canonicalize-location file name nil)))))) ;;; Macroexpansion (defvar *value2tag* (make-hash-table))