From mbaringer at common-lisp.net Sun May 1 10:47:13 2005 From: mbaringer at common-lisp.net (Marco Baringer) Date: Sun, 1 May 2005 12:47:13 +0200 (CEST) Subject: [slime-cvs] CVS update: /slime/slime.el /slime/ChangeLog Message-ID: <20050501104713.8B93C886FB@common-lisp.net> Update of /project/slime/cvsroot//slime In directory common-lisp.net:/tmp/cvs-serv765 Modified Files: slime.el ChangeLog Log Message: * slime.el (slime-inspector-reinspect): New function which reinspects the current object. (slime-inspector-mode-map): Bind slime-inspector-reinspect to g. Date: Sun May 1 12:47:12 2005 Author: mbaringer From lgorrie at common-lisp.net Mon May 2 18:17:21 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 2 May 2005 20:17:21 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-backend.lisp slime/slime.el Message-ID: <20050502181721.73CAD88709@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28972 Modified Files: swank-cmucl.lisp swank-backend.lisp slime.el Log Message: Minor comment tweaks. Date: Mon May 2 20:17:20 2005 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.145 slime/swank-cmucl.lisp:1.146 --- slime/swank-cmucl.lisp:1.145 Fri Apr 29 01:30:25 2005 +++ slime/swank-cmucl.lisp Mon May 2 20:17:19 2005 @@ -15,7 +15,7 @@ ;;;; "Hot fixes" ;;; -;;; Here are necessary bugfixes to the latest released version of +;;; Here are necessary bugfixes to the oldest supported verison of ;;; CMUCL (currently 18e). Any fixes placed here should also be ;;; submitted to the `cmucl-imp' mailing list and confirmed as ;;; good. When a new release is made that includes the fixes we should Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.84 slime/swank-backend.lisp:1.85 --- slime/swank-backend.lisp:1.84 Tue Apr 19 22:18:36 2005 +++ slime/swank-backend.lisp Mon May 2 20:17:19 2005 @@ -1,8 +1,10 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- ;;; ;;; slime-backend.lisp --- SLIME backend interface. ;;; ;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter ;;; ;;; This file defines the functions that must be implemented ;;; separately for each Lisp. Each is declared as a generic function Index: slime/slime.el diff -u slime/slime.el:1.486 slime/slime.el:1.487 --- slime/slime.el:1.486 Sun May 1 12:47:12 2005 +++ slime/slime.el Mon May 2 20:17:19 2005 @@ -1,4 +1,4 @@ -;;;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;+"; indent-tabs-mode: nil -*- +;;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;+"; indent-tabs-mode: nil -*- ;; slime.el -- Superior Lisp Interaction Mode for Emacs ;;;; License ;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller @@ -8997,4 +8997,4 @@ (provide 'slime) -;;;; slime.el ends here +;;; slime.el ends here From lgorrie at common-lisp.net Mon May 2 18:42:22 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 2 May 2005 20:42:22 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050502184222.3E3228870A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30618 Modified Files: slime.el Log Message: If ~/.slime-secret exists then send the contents to Lisp as authentication. Date: Mon May 2 20:42:11 2005 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.487 slime/slime.el:1.488 --- slime/slime.el:1.487 Mon May 2 20:17:19 2005 +++ slime/slime.el Mon May 2 20:42:10 2005 @@ -1512,6 +1512,17 @@ "A list of valid coding systems. Each element is of the form: (NAME MULTIBYTEP CL-NAME)") +(defun slime-secret () + "Finds the magic secret from the user's home directory. +Returns nil if the file doesn't exist or is empty; otherwise the first +line of the file." + (condition-case err + (with-temp-buffer + (insert-file-contents "~/.slime-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + ;;; Interface (defun slime-net-connect (host port) "Establish a connection with a CL." @@ -1528,6 +1539,8 @@ (set-process-coding-system proc slime-net-coding-system slime-net-coding-system)) + (when-let (secret (slime-secret)) + (slime-net-send secret proc)) proc)) (defun slime-make-net-buffer (name) @@ -2499,6 +2512,8 @@ (set-process-coding-system stream slime-net-coding-system slime-net-coding-system) + (when-let (secret (slime-secret)) + (slime-net-send secret stream)) stream)) (defun slime-output-string (string) From lgorrie at common-lisp.net Mon May 2 18:44:52 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 2 May 2005 20:44:52 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050502184452.5005F8870A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30730 Modified Files: swank.lisp Log Message: If ~/.slime-secret exists then insist that Emacs sends the contents (as a password) during initial handshaking. (announce-server-port): Use :IF-EXISTS :ERROR to prevent bad guys from slipping a symlink into /tmp and reading what port Lisp is listening on. Date: Mon May 2 20:44:51 2005 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.295 slime/swank.lisp:1.296 --- slime/swank.lisp:1.295 Thu Apr 21 09:39:12 2005 +++ slime/swank.lisp Mon May 2 20:44:50 2005 @@ -373,7 +373,8 @@ port))) (defun serve-connection (socket style dont-close external-format) - (let ((client (accept-connection socket :external-format external-format))) + (let ((client (accept-authenticated-connection + socket :external-format external-format))) (unless dont-close (close-socket socket)) (let ((connection (create-connection client style external-format))) @@ -381,6 +382,24 @@ (push connection *connections*) (serve-requests connection)))) +(defun accept-authenticated-connection (&rest args) + (let ((new (apply #'accept-connection args)) + (secret (slime-secret))) + (when secret + (unless (string= (decode-message new) secret) + (close new) + (error "Incoming connection doesn't know the password."))) + new)) + +(defun slime-secret () + "Finds the magic secret from the user's home directory. Returns nil +if the file doesn't exist; otherwise the first line of the file." + (with-open-file (in + (merge-pathnames (user-homedir-pathname) + #+unix #p".slime-secret") + :if-does-not-exist nil) + (and in (read-line in nil "")))) + (defun serve-requests (connection) "Read and process all requests on connections." (funcall (connection.serve-requests connection) connection)) @@ -388,7 +407,7 @@ (defun announce-server-port (file port) (with-open-file (s file :direction :output - :if-exists :overwrite + :if-exists :error :if-does-not-exist :create) (format s "~S~%" port)) (simple-announce-function port)) @@ -442,7 +461,8 @@ (let* ((socket (create-socket *loopback-interface* 0)) (port (local-port socket))) (encode-message `(:open-dedicated-output-stream ,port) socket-io) - (accept-connection socket :external-format external-format))) + (accept-authenticated-connection + socket :external-format external-format))) (defun handle-request (connection) "Read and process one request. The processing is done in the extend From lgorrie at common-lisp.net Mon May 2 18:58:54 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 2 May 2005 20:58:54 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050502185854.66EB488717@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32170 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon May 2 20:58:53 2005 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.676 slime/ChangeLog:1.677 --- slime/ChangeLog:1.676 Sun May 1 12:47:12 2005 +++ slime/ChangeLog Mon May 2 20:58:53 2005 @@ -1,3 +1,13 @@ +2005-05-02 Mark Wooding + + * swank.lisp: If ~/.slime-secret exists then insist that Emacs + sends the contents (as a password) during initial handshaking. + (announce-server-port): Use :IF-EXISTS :ERROR to prevent bad guys + from slipping a symlink into /tmp and reading what port Lisp is + listening on. + + * slime.el: If ~/.slime-secret exists then send it, as per above. + 2005-05-01 Marco Baringer * slime.el (slime-inspector-reinspect): New function which From lgorrie at common-lisp.net Tue May 3 18:58:58 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 3 May 2005 20:58:58 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050503185858.16A7F8870C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21069 Modified Files: swank.lisp Log Message: (slime-secret): Removed #+unix conditional. Date: Tue May 3 20:58:55 2005 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.296 slime/swank.lisp:1.297 --- slime/swank.lisp:1.296 Mon May 2 20:44:50 2005 +++ slime/swank.lisp Tue May 3 20:58:54 2005 @@ -395,8 +395,7 @@ "Finds the magic secret from the user's home directory. Returns nil if the file doesn't exist; otherwise the first line of the file." (with-open-file (in - (merge-pathnames (user-homedir-pathname) - #+unix #p".slime-secret") + (merge-pathnames (user-homedir-pathname) #p".slime-secret") :if-does-not-exist nil) (and in (read-line in nil "")))) From lgorrie at common-lisp.net Tue May 3 18:59:57 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 3 May 2005 20:59:57 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050503185957.3B0E78871F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21124 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue May 3 20:59:57 2005 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.677 slime/ChangeLog:1.678 --- slime/ChangeLog:1.677 Mon May 2 20:58:53 2005 +++ slime/ChangeLog Tue May 3 20:59:56 2005 @@ -1,3 +1,8 @@ +2005-05-03 Luke Gorrie + + * swank.lisp (slime-secret): Removed #+unix conditional, suggested + by Edi Weitz. + 2005-05-02 Mark Wooding * swank.lisp: If ~/.slime-secret exists then insist that Emacs From eweitz at common-lisp.net Wed May 4 08:39:22 2005 From: eweitz at common-lisp.net (Edi Weitz) Date: Wed, 4 May 2005 10:39:22 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank-lispworks.lisp Message-ID: <20050504083922.3BC5188713@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26446 Modified Files: ChangeLog swank-lispworks.lisp Log Message: call-with-compilation-hooks: better implementation for LW Date: Wed May 4 10:39:16 2005 Author: eweitz Index: slime/ChangeLog diff -u slime/ChangeLog:1.678 slime/ChangeLog:1.679 --- slime/ChangeLog:1.678 Tue May 3 20:59:56 2005 +++ slime/ChangeLog Wed May 4 10:39:14 2005 @@ -1,3 +1,18 @@ +2005-05-04 Edi Weitz + + * swank-lispworks.lisp (call-with-compilation-hooks): Provide + better implementation. + (compile-file-and-collect-notes): Advice for COMPILE-FILE so + pathname information for undefined functions can be recorded. + (*within-call-with-compilation-hooks*): New special variable used + by CALL-WITH-COMPILATION-HOOKS. + (*undefined-functions-hash*): New special variable to record + pathname information for undefined functions. + (signal-error-database): Make LOCATION parameter optional, use + FILENAME info from error database if not provided. + (signal-undefined-functions): Make LOCATION parameter optional, + use info from *UNDEFINED-FUNCTIONS-HASH* if not provided. + 2005-05-03 Luke Gorrie * swank.lisp (slime-secret): Removed #+unix conditional, suggested Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.69 slime/swank-lispworks.lisp:1.70 --- slime/swank-lispworks.lisp:1.69 Tue Apr 5 15:45:32 2005 +++ slime/swank-lispworks.lisp Wed May 4 10:39:14 2005 @@ -370,9 +370,32 @@ (with-swank-compilation-unit (filename) (compile-file filename :load load-p))) +(defvar *within-call-with-compilation-hooks* nil + "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") + +(defvar *undefined-functions-hash* nil + "Hash table to map info about undefined functions to pathnames.") + +(lw:defadvice (compile-file compile-file-and-collect-notes :around) + (pathname &rest rest) + (prog1 (apply #'lw:call-next-advice pathname rest) + (when *within-call-with-compilation-hooks* + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (let ((unfun-info (list unfun dspec))) + (unless (gethash unfun-info *undefined-functions-hash*) + (setf (gethash unfun-info *undefined-functions-hash*) + pathname))))) + compiler::*unknown-functions*)))) + (defimplementation call-with-compilation-hooks (function) - ;; #'pray instead of #'handler-bind - (funcall function)) + (let ((compiler::*error-database* '()) + (*undefined-functions-hash* (make-hash-table :test 'equal)) + (*within-call-with-compilation-hooks* t)) + (with-compilation-unit () + (prog1 (funcall function) + (signal-error-data-base compiler::*error-database*) + (signal-undefined-functions compiler::*unknown-functions*))))) (defun map-error-database (database fn) (loop for (filename . defs) in database do @@ -496,22 +519,24 @@ nil) location))) -(defun signal-error-data-base (database location) +(defun signal-error-data-base (database &optional location) (map-error-database database (lambda (filename dspec condition) - (declare (ignore filename)) (signal-compiler-condition (format nil "~A" condition) - (make-dspec-progenitor-location dspec location) + (make-dspec-progenitor-location dspec (or location filename)) condition)))) -(defun signal-undefined-functions (htab filename) +(defun signal-undefined-functions (htab &optional filename) (maphash (lambda (unfun dspecs) (dolist (dspec dspecs) (signal-compiler-condition (format nil "Undefined function ~A" unfun) - (make-dspec-progenitor-location dspec filename) + (make-dspec-progenitor-location dspec + (or filename + (gethash (list unfun dspec) + *undefined-functions-hash*))) nil))) htab)) From eweitz at common-lisp.net Wed May 4 08:52:15 2005 From: eweitz at common-lisp.net (Edi Weitz) Date: Wed, 4 May 2005 10:52:15 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050504085215.B37AD8871D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27675 Modified Files: ChangeLog Log Message: fixed date in old entry Date: Wed May 4 10:52:10 2005 Author: eweitz Index: slime/ChangeLog diff -u slime/ChangeLog:1.679 slime/ChangeLog:1.680 --- slime/ChangeLog:1.679 Wed May 4 10:39:14 2005 +++ slime/ChangeLog Wed May 4 10:52:10 2005 @@ -289,7 +289,7 @@ compiled in Emacs buffers, include the :emacs-string as a :snippet hint for search-based M-. lookup. -2003-05-21 Edi Weitz +2005-03-21 Edi Weitz * swank-loader-lisp (*implementation-features*, *os-features*, *architecture-features*): LispWorks was completely missing. From eweitz at common-lisp.net Wed May 4 23:15:44 2005 From: eweitz at common-lisp.net (Edi Weitz) Date: Thu, 5 May 2005 01:15:44 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog slime/swank-lispworks.lisp Message-ID: <20050504231544.C640588720@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4187 Modified Files: ChangeLog swank-lispworks.lisp Log Message: beautify undefined function warnings in LW Date: Thu May 5 01:15:43 2005 Author: eweitz Index: slime/ChangeLog diff -u slime/ChangeLog:1.680 slime/ChangeLog:1.681 --- slime/ChangeLog:1.680 Wed May 4 10:52:10 2005 +++ slime/ChangeLog Thu May 5 01:15:43 2005 @@ -1,3 +1,9 @@ +2005-05-05 Edi Weitz + + * swank-lispworks.lisp (unmangle-unfun): New function to convert + strange symbols in SETF package to SETF function names. + (signal-undefined-functions): Use it. + 2005-05-04 Edi Weitz * swank-lispworks.lisp (call-with-compilation-hooks): Provide Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.70 slime/swank-lispworks.lisp:1.71 --- slime/swank-lispworks.lisp:1.70 Wed May 4 10:39:14 2005 +++ slime/swank-lispworks.lisp Thu May 5 01:15:43 2005 @@ -528,11 +528,30 @@ (make-dspec-progenitor-location dspec (or location filename)) condition)))) +(defun unmangle-unfun (symbol) + "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to +function names like \(SETF GET)." + (or (and (eq (symbol-package symbol) + (load-time-value (find-package :setf))) + (let ((nregex::*regex-groupings* 0) + (nregex::*regex-groups* (make-array 10)) + (symbol-name (symbol-name symbol))) + (and (funcall (load-time-value + (swank::compiled-regex "^\"(.+)\" \"(.+)\"$")) + symbol-name) + (list 'setf + (intern (apply #'subseq symbol-name + (aref nregex::*regex-groups* 2)) + (find-package + (apply #'subseq symbol-name + (aref nregex::*regex-groups* 1)))))))) + symbol)) + (defun signal-undefined-functions (htab &optional filename) (maphash (lambda (unfun dspecs) (dolist (dspec dspecs) (signal-compiler-condition - (format nil "Undefined function ~A" unfun) + (format nil "Undefined function ~A" (unmangle-unfun unfun)) (make-dspec-progenitor-location dspec (or filename (gethash (list unfun dspec) From eweitz at common-lisp.net Thu May 5 08:59:14 2005 From: eweitz at common-lisp.net (Edi Weitz) Date: Thu, 5 May 2005 10:59:14 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: <20050505085914.295AA88030@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19411 Modified Files: swank-lispworks.lisp Log Message: correction: swank.lisp is loaded after swank-lispworks.lisp... Date: Thu May 5 10:59:13 2005 Author: eweitz Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.71 slime/swank-lispworks.lisp:1.72 --- slime/swank-lispworks.lisp:1.71 Thu May 5 01:15:43 2005 +++ slime/swank-lispworks.lisp Thu May 5 10:59:13 2005 @@ -537,7 +537,7 @@ (nregex::*regex-groups* (make-array 10)) (symbol-name (symbol-name symbol))) (and (funcall (load-time-value - (swank::compiled-regex "^\"(.+)\" \"(.+)\"$")) + (compile nil (nregex:regex-compile "^\"(.+)\" \"(.+)\"$"))) symbol-name) (list 'setf (intern (apply #'subseq symbol-name From heller at common-lisp.net Fri May 6 11:12:04 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 6 May 2005 13:12:04 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: <20050506111204.02B34880E0@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28138 Modified Files: swank-cmucl.lisp Log Message: (post-gc-hook): Include the elapsed time and the size distribution. Date: Fri May 6 13:12:04 2005 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.146 slime/swank-cmucl.lisp:1.147 --- slime/swank-cmucl.lisp:1.146 Mon May 2 20:17:19 2005 +++ slime/swank-cmucl.lisp Fri May 6 13:12:03 2005 @@ -15,7 +15,7 @@ ;;;; "Hot fixes" ;;; -;;; Here are necessary bugfixes to the oldest supported verison of +;;; Here are necessary bugfixes to the oldest supported version of ;;; CMUCL (currently 18e). Any fixes placed here should also be ;;; submitted to the `cmucl-imp' mailing list and confirmed as ;;; good. When a new release is made that includes the fixes we should @@ -2064,8 +2064,8 @@ (defun sending-safe-p () (symbol-value (swank-sym :*emacs-connection*))) ;; this should probably not be here, but where else? -(defun eval-in-emacs (form) - (funcall (swank-sym :eval-in-emacs) form)) +(defun eval-in-emacs (form nowait) + (funcall (swank-sym :eval-in-emacs) form nowait)) (defun print-bytes (nbytes &optional stream) "Print the number NBYTES to STREAM in KB, MB, or GB units." @@ -2080,19 +2080,39 @@ (t (format stream "~:D bytes" nbytes)))))) +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + (defun pre-gc-hook (bytes-in-use) (let ((msg (format nil "[Commencing GC with ~A in use.]" (print-bytes bytes-in-use)))) + (setq *gc-start-time* (get-internal-real-time)) (when (sending-safe-p) - (eval-in-emacs `(slime-background-message "%s" ,msg))))) + (eval-in-emacs `(slime-background-message "%s" ,msg) t)))) (defun post-gc-hook (bytes-retained bytes-freed trigger) - (let ((msg (format nil "[GC completed. ~A freed ~A retained ~A trigger]" + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" (print-bytes bytes-freed) (print-bytes bytes-retained) - (print-bytes trigger)))) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) (when (sending-safe-p) - (eval-in-emacs `(slime-background-message "%s" ,msg))))) + (eval-in-emacs `(slime-background-message "%s" ,msg) t)))) (defun install-gc-hooks () (setq ext:*gc-notify-before* #'pre-gc-hook) From heller at common-lisp.net Fri May 6 11:13:21 2005 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 6 May 2005 13:13:21 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050506111321.7D3BA8870F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28213 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri May 6 13:13:19 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.681 slime/ChangeLog:1.682 --- slime/ChangeLog:1.681 Thu May 5 01:15:43 2005 +++ slime/ChangeLog Fri May 6 13:13:18 2005 @@ -1,3 +1,8 @@ +2005-05-06 Helmut Eller + + * swank-cmucl.lisp (post-gc-hook): Include the elapsed time and + the size distribution. + 2005-05-05 Edi Weitz * swank-lispworks.lisp (unmangle-unfun): New function to convert From aruttenberg at common-lisp.net Fri May 6 16:30:18 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 6 May 2005 18:30:18 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: <20050506163018.D1A1A88716@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22555/slime Modified Files: swank-openmcl.lisp Log Message: Fix specializer-name to handle structure-class, to fix edit definition of methods specialized on ddestructs Date: Fri May 6 18:30:05 2005 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.92 slime/swank-openmcl.lisp:1.93 --- slime/swank-openmcl.lisp:1.92 Mon Nov 29 18:35:03 2004 +++ slime/swank-openmcl.lisp Fri May 6 18:30:02 2005 @@ -118,8 +118,9 @@ (defun specializer-name (spec) (etypecase spec (cons spec) - ((or swank-mop:standard-class built-in-class) (swank-mop:class-name spec)) - (swank-mop:eql-specializer `(eql ,(swank-mop:eql-specializer-object spec))))) + ((or structure-class swank-mop:standard-class built-in-class) (swank-mop:class-name spec)) + (swank-mop:eql-specializer `(eql ,(swank-mop:eql-specializer-object spec))) + )) ;;; TCP Server From aruttenberg at common-lisp.net Fri May 6 16:34:01 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 6 May 2005 18:34:01 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050506163401.7323188729@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23530/slime Modified Files: ChangeLog Log Message: Date: Fri May 6 18:34:00 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.682 slime/ChangeLog:1.683 --- slime/ChangeLog:1.682 Fri May 6 13:13:18 2005 +++ slime/ChangeLog Fri May 6 18:34:00 2005 @@ -1,3 +1,8 @@ +2005-05-06 Alan Ruttenberg + * swank-openmcl.lisp specializer-name didn't handle + structure-class which caused meta-. of methods specialized on + defstruct arguments to fail. + 2005-05-06 Helmut Eller * swank-cmucl.lisp (post-gc-hook): Include the elapsed time and From heller at common-lisp.net Wed May 11 14:45:20 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 11 May 2005 16:45:20 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-source-path-parser.lisp Message-ID: <20050511144520.0B06588720@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6292 Modified Files: swank-source-path-parser.lisp Log Message: (read-and-record-source-map): Ensure that at least the toplevel form is in the source-map. Date: Wed May 11 16:45:20 2005 Author: heller Index: slime/swank-source-path-parser.lisp diff -u slime/swank-source-path-parser.lisp:1.13 slime/swank-source-path-parser.lisp:1.14 --- slime/swank-source-path-parser.lisp:1.13 Fri Apr 1 15:59:48 2005 +++ slime/swank-source-path-parser.lisp Wed May 11 16:45:20 2005 @@ -64,8 +64,14 @@ subexpressions of the object to stream positions." (let* ((*source-map* (make-hash-table :test #'eq)) (*readtable* (make-source-recording-readtable *readtable* - *source-map*))) - (values (read stream) *source-map*))) + *source-map*)) + (start (file-position stream)) + (form (read stream)) + (end (file-position stream))) + ;; ensure that at least FORM is in the source-map + (unless (gethash form *source-map*) + (push (cons start end) (gethash form *source-map*))) + (values form *source-map*))) (defun read-source-form (n stream) "Read the Nth toplevel form number with source location recording. From heller at common-lisp.net Wed May 11 14:46:42 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 11 May 2005 16:46:42 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050511144642.4D5FF88729@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6812 Modified Files: slime.el Log Message: (slime-remove-old-overlays): Remove overlays in all slime buffers not only in the current buffer. (slime-filter-buffers): New helper. (slime-display-completion-list): Take the completed prefix as additional argument to initialize completion-base-size. This is apparently needed to make mouse-selection working. (slime-maybe-complete-as-filename): Factor for common code in slime-complete-symbol* and slime-simple-complete-symbol. Date: Wed May 11 16:46:41 2005 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.488 slime/slime.el:1.489 --- slime/slime.el:1.488 Mon May 2 20:42:10 2005 +++ slime/slime.el Wed May 11 16:46:40 2005 @@ -3593,13 +3593,24 @@ (defun slime-remove-old-overlays () "Delete the existing Slime overlays in the current buffer." - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (dolist (o (overlays-at (point))) - (when (overlay-get o 'slime) - (delete-overlay o))) - (goto-char (next-overlay-change (point)))))) + (dolist (buffer (slime-filter-buffers (lambda () slime-mode))) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (dolist (o (overlays-at (point))) + (when (overlay-get o 'slime) + (delete-overlay o))) + (goto-char (next-overlay-change (point)))))))) + +(defun slime-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + ;;;;; Merging together compiler notes in the same location. @@ -4648,12 +4659,14 @@ (equal (buffer-name (window-buffer slime-completions-window)) slime-completions-buffer-name))) -(defun slime-display-completion-list (completion-list) +(defun slime-display-completion-list (completions base) (let ((savedp (slime-complete-maybe-save-window-configuration))) (with-output-to-temp-buffer slime-completions-buffer-name - (display-completion-list completion-list) - (with-current-buffer standard-output - (set-syntax-table lisp-mode-syntax-table))) + (display-completion-list completions) + (let ((offset (- (point) 1 (length base)))) + (with-current-buffer standard-output + (setq completion-base-size offset) + (set-syntax-table lisp-mode-syntax-table)))) (when savedp (setq slime-completions-window (get-buffer-window slime-completions-buffer-name))))) @@ -4665,14 +4678,14 @@ (interactive) (funcall slime-complete-symbol-function)) -(defun* slime-complete-symbol* () +(defun slime-complete-symbol* () "Expand abbreviations and complete the symbol at point." ;; NB: It is only the name part of the symbol that we actually want ;; to complete -- the package prefix, if given, is just context. - (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) - (return-from slime-complete-symbol* - (let ((comint-completion-addsuffix '("/" . "\""))) - (comint-dynamic-complete-as-filename)))) + (or (slime-maybe-complete-as-filename) + (slime-expand-abbreviations-and-complete))) + +(defun slime-expand-abbreviations-and-complete () (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) (beg (move-marker (make-marker) (slime-symbol-start-pos))) (prefix (buffer-substring-no-properties beg end)) @@ -4697,13 +4710,15 @@ ;; Incomplete (t (when (member completed-prefix completion-set) - (slime-minibuffer-respecting-message "Complete but not unique")) + (slime-minibuffer-respecting-message + "Complete but not unique")) (let ((unambiguous-completion-length (loop for c in completion-set minimizing (or (mismatch completed-prefix c) (length completed-prefix))))) (goto-char (+ beg unambiguous-completion-length)) - (slime-display-completion-list completion-set) + (slime-display-completion-list completion-set + completed-prefix) (slime-complete-delay-restoration))))))) (defun slime-complete-symbol*-fancy-bit () @@ -4728,31 +4743,39 @@ (not (minibuffer-window-active-p (minibuffer-window)))) (slime-echo-arglist)))))))) -(defun* slime-simple-complete-symbol () +(defun slime-simple-complete-symbol () "Complete the symbol at point. Perform completion more similar to Emacs' complete-symbol." - (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) - (return-from slime-simple-complete-symbol - (comint-dynamic-complete-as-filename))) - (let* ((end (point)) - (beg (slime-symbol-start-pos)) - (prefix (buffer-substring-no-properties beg end))) - (destructuring-bind (completion-set completed-prefix) - (slime-simple-completions prefix) - (if (null completion-set) - (progn (slime-minibuffer-respecting-message - "Can't find completion for \"%s\"" prefix) - (ding) - (slime-complete-restore-window-configuration)) - (insert-and-inherit (substring completed-prefix (length prefix))) - (cond ((= (length completion-set) 1) - (slime-minibuffer-respecting-message "Sole completion") - (slime-complete-restore-window-configuration)) - ;; Incomplete - (t - (slime-minibuffer-respecting-message "Complete but not unique") - (slime-display-completion-list completion-set) - (slime-complete-delay-restoration))))))) + (or (slime-maybe-complete-as-filename) + (let* ((end (point)) + (beg (slime-symbol-start-pos)) + (prefix (buffer-substring-no-properties beg end)) + (result (slime-simple-completions prefix))) + (destructuring-bind (completions partial) result + (if (null completions) + (progn (slime-minibuffer-respecting-message + "Can't find completion for \"%s\"" prefix) + (ding) + (slime-complete-restore-window-configuration)) + (insert-and-inherit (substring partial (length prefix))) + (cond ((= (length completions) 1) + (slime-minibuffer-respecting-message "Sole completion") + (slime-complete-restore-window-configuration)) + ;; Incomplete + (t + (slime-minibuffer-respecting-message + "Complete but not unique") + (slime-display-completion-list completions partial) + (slime-complete-delay-restoration)))))))) + +(defun slime-maybe-complete-as-filename () + "If point is at a string starting with \", complete it as filename. +Return nil iff if point is not at filename." + (if (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) + (let ((comint-completion-addsuffix '("/" . "\""))) + (comint-dynamic-complete-as-filename) + t) + nil)) (defun slime-minibuffer-respecting-message (format &rest format-args) "Display TEXT as a message, without hiding any minibuffer contents." @@ -6405,10 +6428,8 @@ "List of overlays created in source code buffers to highlight expressions.") (defun sldb-buffers () - (remove-if-not (lambda (buffer) - (with-current-buffer buffer - (eq major-mode 'sldb-mode))) - (buffer-list))) + "Return a list of all sldb buffers." + (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode)))) (defun sldb-find-buffer (thread &optional connection) (let ((connection (or connection (slime-connection)))) From heller at common-lisp.net Wed May 11 14:47:07 2005 From: heller at common-lisp.net (Helmut Eller) Date: Wed, 11 May 2005 16:47:07 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050511144707.8B58088729@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6847 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed May 11 16:47:06 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.683 slime/ChangeLog:1.684 --- slime/ChangeLog:1.683 Fri May 6 18:34:00 2005 +++ slime/ChangeLog Wed May 11 16:47:06 2005 @@ -1,3 +1,19 @@ +2005-05-11 Tim Daly Jr. + + * swank-source-path-parser.lisp (read-and-record-source-map): + Ensure that at least the toplevel form is in the source-map. + +2005-05-11 Helmut Eller + + * slime.el (slime-remove-old-overlays): Remove overlays in all + slime buffers not only in the current buffer. + (slime-filter-buffers): New helper. + (slime-display-completion-list): Take the completed prefix as + additional argument to initialize completion-base-size. This is + apparently needed to make mouse-selection working. + (slime-maybe-complete-as-filename): Factor for common code in + slime-complete-symbol* and slime-simple-complete-symbol. + 2005-05-06 Alan Ruttenberg * swank-openmcl.lisp specializer-name didn't handle structure-class which caused meta-. of methods specialized on From aruttenberg at common-lisp.net Thu May 12 19:04:42 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 12 May 2005 21:04:42 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050512190442.1185C8870E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10608/slime Modified Files: swank.lisp Log Message: 2005-05-12 Alan Ruttenberg * swank.lisp Add ability to customize behavior of the repl. To do so, add a function to the list swank::*slime-repl-eval-hooks*. This function is passed the form typed into the repl. The function should decide whether it wants to handle evaluation of the form. If not, call (repl-eval-hook-pass) and the next hook is tried. Otherwise the values the function returns are used instead of calling eval. Inside the body of the function you can also suppress having the repl print the result by calling (repl-suppress-output) and/or suppress the advancement of the history variables (*** ** * /// // /) by calling (repl-suppress-advance-history). Date: Thu May 12 21:04:41 2005 Author: aruttenberg Index: slime/swank.lisp diff -u slime/swank.lisp:1.297 slime/swank.lisp:1.298 --- slime/swank.lisp:1.297 Tue May 3 20:58:54 2005 +++ slime/swank.lisp Thu May 12 21:04:41 2005 @@ -1692,6 +1692,37 @@ (list (get-output-stream-string s) (format nil "~{~S~^~%~}" values))))) +(defvar *slime-repl-advance-history* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from advancing the history - * ** *** etc.") + +(defvar *slime-repl-suppress-output* nil + "In the dynamic scope of a single form typed at the repl, is set to nil to + prevent the repl from printing the result of the evalation.") + +(defvar *slime-repl-eval-hook-pass* (gensym "PASS") + "Token to indicate that a repl hook declines to evaluate the form") + +(defvar *slime-repl-eval-hooks* nil + "A list of functions. When the repl is about to eval a form, first try running each of + these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* + is considered a replacement for calling eval. If there are no hooks, or all + pass, then eval is used.") + +(defslimefun repl-eval-hook-pass () + "call when repl hook declines to evaluate the form" + (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) + +(defslimefun repl-suppress-output () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from printing the result of the evalation." + (setq *slime-repl-suppress-output* t)) + +(defslimefun repl-suppress-advance-history () + "In the dynamic scope of a single form typed at the repl, call to + prevent the repl from advancing the history - * ** *** etc." + (setq *slime-repl-advance-history* nil)) + (defun eval-region (string &optional package-update-p) "Evaluate STRING and return the result. If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package @@ -1706,7 +1737,15 @@ (force-output) (return (values values -))) (setq - form) - (setq values (multiple-value-list (eval form))) + (if *slime-repl-eval-hooks* + (loop for hook in *slime-repl-eval-hooks* + for res = (catch *slime-repl-eval-hook-pass* (multiple-value-list (funcall hook form))) + until (not (eq res *slime-repl-eval-hook-pass*)) + finally + (if (eq res *slime-repl-eval-hook-pass*) + (setq values (multiple-value-list (eval form))) + (setq values res))) + (setq values (multiple-value-list (eval form)))) (force-output))))) (when (and package-update-p (not (eq *package* *buffer-package*))) (send-to-emacs @@ -1786,13 +1825,19 @@ (defslimefun listener-eval (string) (clear-user-input) (with-buffer-syntax () - (multiple-value-bind (values last-form) (eval-region string t) - (setq +++ ++ ++ + + last-form - *** ** ** * * (car values) - /// // // / / values) - (cond ((null values) "; No value") - (t - (format nil "~{~S~^~%~}" values)))))) + (let ((*slime-repl-suppress-output* :unset) + (*slime-repl-advance-history* :unset)) + (multiple-value-bind (values last-form) (eval-region string t) + (unless (or (and (eq values nil) (eq last-form nil)) + (eq *slime-repl-advance-history* nil)) + (setq *** ** ** * * (car values) + /// // // / / values)) + (setq +++ ++ ++ + + last-form) + (if (eq *slime-repl-suppress-output* t) + "" + (cond ((null values) "; No value") + (t + (format nil "~{~S~^~%~}" values)))))))) (defslimefun ed-in-emacs (&optional what) "Edit WHAT in Emacs. From aruttenberg at common-lisp.net Thu May 12 19:05:05 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 12 May 2005 21:05:05 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050512190505.1844688735@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10637/slime Modified Files: ChangeLog Log Message: Date: Thu May 12 21:05:04 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.684 slime/ChangeLog:1.685 --- slime/ChangeLog:1.684 Wed May 11 16:47:06 2005 +++ slime/ChangeLog Thu May 12 21:05:04 2005 @@ -1,3 +1,18 @@ +2005-05-12 Alan Ruttenberg + + * swank.lisp Add ability to customize behavior of the repl. To do + so, add a function to the list swank::*slime-repl-eval-hooks*. + This function is passed the form typed into the repl. The function + should decide whether it wants to handle evaluation of the + form. If not, call (repl-eval-hook-pass) and the next hook is + tried. Otherwise the values the function returns are used instead + of calling eval. Inside the body of the function you can also + suppress having the repl print the result by calling + (repl-suppress-output) and/or suppress the advancement of the + history variables (*** ** * /// // /) by calling + (repl-suppress-advance-history). + + 2005-05-11 Tim Daly Jr. * swank-source-path-parser.lisp (read-and-record-source-map): From asimon at common-lisp.net Sat May 14 09:14:00 2005 From: asimon at common-lisp.net (Andras Simon) Date: Sat, 14 May 2005 11:14:00 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-abcl.lisp Message-ID: <20050514091400.C722B8873E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17705 Modified Files: swank-abcl.lisp Log Message: MOP symbols are now in the MOP package in ABCL Date: Sat May 14 11:13:58 2005 Author: asimon Index: slime/swank-abcl.lisp diff -u slime/swank-abcl.lisp:1.25 slime/swank-abcl.lisp:1.26 --- slime/swank-abcl.lisp:1.25 Sat Apr 9 09:06:35 2005 +++ slime/swank-abcl.lisp Sat May 14 11:13:58 2005 @@ -52,44 +52,44 @@ cl:method cl:standard-class ;; standard-class readers - sys::class-default-initargs - sys::class-direct-default-initargs - sys::class-direct-slots - sys::class-direct-subclasses - sys::class-direct-superclasses - sys::eql-specializer + mop::class-default-initargs + mop::class-direct-default-initargs + mop::class-direct-slots + mop::class-direct-subclasses + mop::class-direct-superclasses + mop::eql-specializer class-finalized-p ;;dummy cl:class-name - sys::class-precedence-list + mop::class-precedence-list class-prototype ;;dummy - sys::class-slots + mop::class-slots specializer-direct-methods ;;dummy ;; eql-specializer accessors - sys::eql-specializer-object + mop::eql-specializer-object ;; generic function readers - sys::generic-function-argument-precedence-order + mop::generic-function-argument-precedence-order generic-function-declarations ;;dummy - sys::generic-function-lambda-list - sys::generic-function-methods - sys::generic-function-method-class - sys::generic-function-method-combination - sys::generic-function-name + mop::generic-function-lambda-list + mop::generic-function-methods + mop::generic-function-method-class + mop::generic-function-method-combination + mop::generic-function-name ;; method readers - sys::method-generic-function - sys::method-function - sys::method-lambda-list - sys::method-specializers - sys::method-qualifiers + mop::method-generic-function + mop::method-function + mop::method-lambda-list + mop::method-specializers + mop::method-qualifiers ;; slot readers - sys::slot-definition-allocation + mop::slot-definition-allocation slot-definition-documentation ;;dummy - sys::slot-definition-initargs - sys::slot-definition-initform - sys::slot-definition-initfunction - sys::slot-definition-name + mop::slot-definition-initargs + mop::slot-definition-initform + mop::slot-definition-initfunction + mop::slot-definition-name slot-definition-type ;;dummy - sys::slot-definition-readers - sys::slot-definition-writers)) + mop::slot-definition-readers + mop::slot-definition-writers)) ;;;; TCP Server @@ -361,20 +361,20 @@ (defimplementation make-default-inspector () (make-instance 'abcl-inspector)) -(defmethod inspect-for-emacs ((slot sys::slot-definition) (inspector abcl-inspector)) +(defmethod inspect-for-emacs ((slot mop::slot-definition) (inspector abcl-inspector)) (declare (ignore inspector)) (values "A slot." - `("Name: " (:value ,(sys::slot-definition-name slot)) + `("Name: " (:value ,(mop::slot-definition-name slot)) (:newline) "Documentation:" (:newline) ,@(when (slot-definition-documentation slot) `((:value ,(slot-definition-documentation slot)) (:newline))) "Initialization:" (:newline) - " Args: " (:value ,(sys::slot-definition-initargs slot)) (:newline) - " Form: " ,(if (sys::slot-definition-initfunction slot) - `(:value ,(sys::slot-definition-initform slot)) + " Args: " (:value ,(mop::slot-definition-initargs slot)) (:newline) + " Form: " ,(if (mop::slot-definition-initfunction slot) + `(:value ,(mop::slot-definition-initform slot)) "#") (:newline) - " Function: " (:value ,(sys::slot-definition-initfunction slot)) + " Function: " (:value ,(mop::slot-definition-initfunction slot)) (:newline)))) (defmethod inspect-for-emacs ((f function) (inspector abcl-inspector)) @@ -397,10 +397,10 @@ (defimplementation inspect-for-emacs ((o t) (inspector abcl-inspector)) (let* ((class (class-of o)) - (slots (sys::class-slots class))) + (slots (mop::class-slots class))) (values (format nil "~A~% is a ~A" o class) (mapcar (lambda (slot) - (let ((name (sys::slot-definition-name slot))) + (let ((name (mop::slot-definition-name slot))) (cons (princ-to-string name) (slot-value o name)))) slots)))) From mbaringer at common-lisp.net Wed May 18 10:15:35 2005 From: mbaringer at common-lisp.net (Marco Baringer) Date: Wed, 18 May 2005 12:15:35 +0200 (CEST) Subject: [slime-cvs] CVS update: /slime/ChangeLog Message-ID: <20050518101535.F2BC5880A4@common-lisp.net> Update of /project/slime/cvsroot//slime In directory common-lisp.net:/tmp/cvs-serv16592 Modified Files: ChangeLog Log Message: Date: Wed May 18 12:15:35 2005 Author: mbaringer From mbaringer at common-lisp.net Wed May 18 10:16:06 2005 From: mbaringer at common-lisp.net (Marco Baringer) Date: Wed, 18 May 2005 12:16:06 +0200 (CEST) Subject: [slime-cvs] CVS update: /slime/slime.el Message-ID: <20050518101606.3407F88735@common-lisp.net> Update of /project/slime/cvsroot//slime In directory common-lisp.net:/tmp/cvs-serv16621 Modified Files: slime.el Log Message: (slime-repl-inputed-output-face): new face. (slime-current-output-id): New variable. (slime-dispatch-event): Bind slime-current-output-id when neccessary. (slime-repl-insert-prompt): Add the neccessary text properties to the result. (reify-old-output): New function which makes sure swank sees \(swank::get-**** ...) while the user sees the printed representation of the object. (slime-repl-return): When called on a old output (as per the slime-repl-old-output text property, call slime-repl-grab-old-output. (slime-repl-send-input): Added the slime-repl-old-input text property. (slime-repl-grab-old-input): Keep the old input's text properties (unwanted text properties are removed later). (slime-repl-grab-old-output): New function. (slime-repl-clear-buffer): Added call to swank::clear-**** (slime-repl-clear-output): Added call to swank::clear-**** and bind inhibit-read-only to nil. (slime-inspect): Call slime-read-object to get the value to inspect. (slime-read-object): New function which either reads an object from the minibuffer or returns the object at point if it has the slime-repl-old-output text property. Date: Wed May 18 12:16:05 2005 Author: mbaringer From mbaringer at common-lisp.net Wed May 18 10:16:32 2005 From: mbaringer at common-lisp.net (Marco Baringer) Date: Wed, 18 May 2005 12:16:32 +0200 (CEST) Subject: [slime-cvs] CVS update: /slime/swank.lisp Message-ID: <20050518101632.754BB88735@common-lisp.net> Update of /project/slime/cvsroot//slime In directory common-lisp.net:/tmp/cvs-serv16958 Modified Files: swank.lisp Log Message: (*current-id*, ****): New variables. (add-****, get-****, clear-last-****, clear-****): New functions for manipulating the repl history. (listener-eval): Add * to ****. Date: Wed May 18 12:16:32 2005 Author: mbaringer From mbaringer at common-lisp.net Wed May 18 10:23:26 2005 From: mbaringer at common-lisp.net (Marco Baringer) Date: Wed, 18 May 2005 12:23:26 +0200 (CEST) Subject: [slime-cvs] CVS update: /slime/ChangeLog Message-ID: <20050518102326.E235288735@common-lisp.net> Update of /project/slime/cvsroot//slime In directory common-lisp.net:/tmp/cvs-serv17131 Modified Files: ChangeLog Log Message: Date: Wed May 18 12:23:26 2005 Author: mbaringer From lgorrie at common-lisp.net Thu May 19 02:15:24 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 19 May 2005 04:15:24 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050519021524.7B3718873F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13126 Modified Files: swank.lisp Log Message: (*record-repl-results*): Variable to enable/disable recording of REPL results. True by default. (*repl-results*): Renamed from ****. Date: Thu May 19 04:15:13 2005 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.299 slime/swank.lisp:1.300 --- slime/swank.lisp:1.299 Wed May 18 12:16:31 2005 +++ slime/swank.lisp Thu May 19 04:15:10 2005 @@ -34,6 +34,7 @@ #:*swank-pprint-bindings* #:*default-worker-thread-bindings* #:*macroexpand-printer-bindings* + #:*record-repl-results* ;; These are re-exported directly from the backend: #:buffer-first-change #:frame-source-location-for-emacs @@ -1825,26 +1826,12 @@ (let ((p (setq *package* (guess-package-from-string package)))) (list (package-name p) (package-string-for-prompt p)))) -;;; *, **, and *** are not enough -(defparameter **** (list)) -(defun add-**** (id val) - (setf **** (acons id val ****)) - t) - -(defun get-**** (id) - (let ((previous-output (assoc id ****))) - (when (null previous-output) - (error "Attempt to access no longer existing result (number ~D)." id)) - (cdr previous-output))) +(defvar *record-repl-results* t + "Non-nil means that REPL results are saved in *REPL-RESULTS*.") -(defun clear-last-**** () - (setf **** (rest ****)) - t) - -(defun clear-**** () - (setf **** (list)) - t) +(defparameter *repl-results* '() + "Association list of old repl results.") (defslimefun listener-eval (string) (clear-user-input) @@ -1856,13 +1843,38 @@ (eq *slime-repl-advance-history* nil)) (setq *** ** ** * * (car values) /// // // / / values) - (add-**** *current-id* *)) + (when *record-repl-results* + (add-repl-result *current-id* *))) (setq +++ ++ ++ + + last-form) (if (eq *slime-repl-suppress-output* t) "" (cond ((null values) "; No value") (t (format nil "~{~S~^~%~}" values)))))))) + +(defun add-repl-result (id val) + (push (cons id val) *repl-results*) + t) + +(defslimefun get-repl-result (id) + "Get the result of the previous REPL evaluation with ID." + (let ((previous-output (assoc id *repl-results*))) + (when (null previous-output) + (if *record-repl-results* + (error "Attempt to access no longer existing result (number ~D)." id) + (error "Attempt to access unrecorded result (number ~D). ~&See ~S." + id '*record-repl-results*))) + (cdr previous-output))) + +(defslimefun clear-last-repl-result () + "Forget the result of the previous REPL evaluation." + (pop *repl-results*) + t) + +(defslimefun clear-repl-results () + "Forget the results of all previous REPL evaluations." + (setf *repl-results* '())) + t) (defslimefun ed-in-emacs (&optional what) "Edit WHAT in Emacs. From lgorrie at common-lisp.net Thu May 19 02:15:39 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 19 May 2005 04:15:39 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050519021539.D771A8873F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13453 Modified Files: slime.el Log Message: (slime-property-bounds): Factored out this common part of slime-repl-grab-old-{input,output}. (slime-read-object): Avoid inline CL code. Date: Thu May 19 04:15:38 2005 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.490 slime/slime.el:1.491 --- slime/slime.el:1.490 Wed May 18 12:16:04 2005 +++ slime/slime.el Thu May 19 04:15:37 2005 @@ -2720,8 +2720,9 @@ (recenter -1)))))) (defun slime-repl-current-input () - "Return the current input as string. The input is the region from -after the last prompt to the end of buffer." + "Return the current input as string. +The input is the region from after the last prompt to the end of +buffer. Presentations of old results are expanded into code." (let ((str-props (buffer-substring slime-repl-input-start-mark slime-repl-input-end-mark)) (str-no-props (buffer-substring-no-properties slime-repl-input-start-mark @@ -2729,18 +2730,24 @@ (reify-old-output str-props str-no-props))) (defun reify-old-output (str-props str-no-props) - (let ((pos (if (get-text-property 0 'slime-repl-old-output str-props) - 0 - (next-single-property-change 0 'slime-repl-old-output str-props)))) - (if pos + (let ((pos (slime-property-position 'slime-repl-old-output str-props))) + (if (null pos) + str-no-props (let ((end-pos (or (next-single-property-change pos 'slime-repl-old-output str-props) (length str-props))) (id (get-text-property pos 'slime-repl-old-output str-props))) (concat (substring str-no-props 0 pos) - (slime-prin1-to-string `(swank::get-**** ,id)) + ;; Eval in the reader so that we play nice with quote. + ;; -luke (19/May/2005) + "#." (slime-prin1-to-string `(swank:get-repl-result ,id)) (reify-old-output (substring str-props end-pos) - (substring str-no-props end-pos)))) - str-no-props))) + (substring str-no-props end-pos))))))) + +(defun slime-property-position (text-property &optional object) + "Return the first position of TEXT-PROPERTY, or nil." + (if (get-text-property 0 text-property object) + 0 + (next-single-property-change 0 text-property object))) (defun slime-repl-add-to-input-history (string) (when (and (plusp (length string)) @@ -2929,23 +2936,10 @@ If replace it non-nil the current input is replaced with the old input; otherwise the new input is appended. The old input has the text property `slime-repl-old-input'." - (let ((prop 'slime-repl-old-input)) - (let* ((beg (save-excursion - ;; previous-single-char-property-change searches for - ;; a property change from the previous character, - ;; but we want to look for a change from the - ;; point. We step forward one char to avoid doing - ;; the wrong thing if we're at the beginning of the - ;; old input. -luke (18/Jun/2004) - (ignore-errors (forward-char)) - (previous-single-char-property-change (point) prop))) - (end (save-excursion - (goto-char (next-single-char-property-change (point) prop)) - (skip-chars-backward "\n \t\r" beg) - (point))) - (old-input (buffer-substring beg end)) ;;preserve - ;;properties, they will be removed later - (offset (- (point) beg))) + (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input) + (let ((old-input (buffer-substring beg end)) ;;preserve + ;;properties, they will be removed later + (offset (- (point) beg))) ;; Append the old input or replace the current input (cond (replace (goto-char slime-repl-input-start-mark)) (t (goto-char slime-repl-input-end-mark) @@ -2960,21 +2954,8 @@ If replace it non-nil the current input is replaced with the old output; otherwise the new input is appended. The old output has the text property `slime-repl-old-output'." - (let ((prop 'slime-repl-old-output)) - (let* ((beg (save-excursion - ;; previous-single-char-property-change searches for - ;; a property change from the previous character, - ;; but we want to look for a change from the - ;; point. We step forward one char to avoid doing - ;; the wrong thing if we're at the beginning of the - ;; old input. -luke (18/Jun/2004) - (ignore-errors (forward-char)) - (previous-single-char-property-change (point) prop))) - (end (save-excursion - (goto-char (next-single-char-property-change (point) prop)) - (skip-chars-backward "\n \t\r" beg) - (point))) - (old-output (buffer-substring beg end))) ;;keep properties + (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-output) + (let ((old-output (buffer-substring beg end))) ;;keep properties ;; Append the old input or replace the current input (cond (replace (goto-char slime-repl-input-start-mark)) (t (goto-char slime-repl-input-end-mark) @@ -2986,6 +2967,24 @@ '(face slime-repl-inputed-output-face) (insert old-output)))))) +(defun slime-property-bounds (prop) + "Return two the positions of the previous and next changes to PROP. +PROP is the name of a text property." + (let* ((beg (save-excursion + ;; previous-single-char-property-change searches for a + ;; property change from the previous character, but we + ;; want to look for a change from the point. We step + ;; forward one char to avoid doing the wrong thing if + ;; we're at the beginning of the old input. -luke + ;; (18/Jun/2004) + (ignore-errors (forward-char)) + (previous-single-char-property-change (point) prop))) + (end (save-excursion + (goto-char (next-single-char-property-change (point) prop)) + (skip-chars-backward "\n \t\r" beg) + (point)))) + (values beg end))) + (defun slime-repl-closing-return () "Evaluate the current input string after closing all open lists." (interactive) @@ -3022,7 +3021,7 @@ (defun slime-repl-clear-buffer () "Delete the entire output generated by the Lisp process." (interactive) - (slime-eval `(swank::clear-****)) + (slime-eval `(swank::clear-repl-results)) (set-marker slime-repl-last-input-start-mark nil) (let ((inhibit-read-only t)) (delete-region (point-min) (slime-repl-input-line-beginning-position)) @@ -3031,7 +3030,7 @@ (defun slime-repl-clear-output () "Delete the output inserted since the last input." (interactive) - (slime-eval `(swank::clear-last-****)) + (slime-eval `(swank::clear-last-repl-result)) (let ((start (save-excursion (slime-repl-previous-prompt) (ignore-errors (forward-sexp)) @@ -7398,9 +7397,7 @@ (defun slime-read-object (prompt) (let ((id (get-text-property (point) 'slime-repl-old-output))) (if id - `(swank::progn - (swank::reset-inspector) - (swank::inspect-object (swank::get-**** ,id))) + `(swank:init-inspector ,(format "(swank:get-repl-result %S)" id)) `(swank:init-inspector ,(slime-read-from-minibuffer "Inspect value (evaluated): " (slime-sexp-at-point)))))) From lgorrie at common-lisp.net Thu May 19 02:24:14 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 19 May 2005 04:24:14 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050519022414.710BD88742@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13794 Modified Files: ChangeLog Log Message: Date: Thu May 19 04:24:13 2005 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.687 slime/ChangeLog:1.688 --- slime/ChangeLog:1.687 Wed May 18 12:23:26 2005 +++ slime/ChangeLog Thu May 19 04:24:13 2005 @@ -1,3 +1,13 @@ +2005-05-19 Luke Gorrie + + * swank.lisp (*record-repl-results*): Variable to enable/disable + recording of REPL results. True by default. + (*repl-results*): Renamed from ****. + + * slime.el (slime-property-bounds): Factored out this common part + of slime-repl-grab-old-{input,output}. + (slime-read-object): Avoid inline CL code. + 2005-05-18 Antonio Menezes Leitao * slime.el (slime-repl-inputed-output-face): new face. From aruttenberg at common-lisp.net Thu May 19 17:06:15 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 19 May 2005 19:06:15 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050519170615.7D60A8872F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3677/slime Modified Files: slime.el Log Message: Date: Thu May 19 19:06:14 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.491 slime/slime.el:1.492 --- slime/slime.el:1.491 Thu May 19 04:15:37 2005 +++ slime/slime.el Thu May 19 19:06:13 2005 @@ -375,6 +375,18 @@ "Face for Lisp output in the SLIME REPL." :group 'slime-repl) + +(defface slime-repl-output-mouseover-face + (if (slime-face-inheritance-possible-p) + '((t + (:box + (:line-width 1 :color "black" :style released-button) + :inherit + (slime-repl-inputed-output-face)))) + '((t (:box (:line-width 1 :color "black"))))) + "Face for Lisp output in the SLIME REPL, when the mouse hovers over it" + :group 'slime-repl) + (defface slime-repl-input-face '((t (:bold t))) "Face for previous input in the SLIME REPL." @@ -837,11 +849,14 @@ "Execute all functions in `slime-pre-command-actions', then NIL it." (dolist (undo-fn slime-pre-command-actions) (ignore-errors (funcall undo-fn))) - (setq slime-pre-command-actions nil)) + (setq slime-pre-command-actions nil) + (slime-presentation-command-hook)) (defun slime-post-command-hook () (when (and slime-mode (slime-connected-p)) - (slime-process-available-input))) + (slime-process-available-input)) + (when (null pre-command-hook) ; sometimes this is lost + (add-hook 'pre-command-hook 'slime-pre-command-hook))) (defun slime-setup-command-hooks () "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." @@ -2658,6 +2673,66 @@ (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) +;; alanr +(defun slime-presentation-command-hook () + (let* ((props-here (text-properties-at (point))) + (props-before (and (not (= (point) (point-min))) (text-properties-at (1- (point))))) + (inside (and (getf props-here 'slime-repl-old-output))) + (at-beginning (and inside (not (getf props-before 'slime-repl-old-output)))) + (at-end (and (or (= (point) (point-max)) (not (getf props-here 'slime-repl-old-output))) + (getf props-before 'slime-repl-old-output))) + (start (cond (at-beginning (point)) + (inside (previous-single-property-change (point) 'slime-repl-old-output)) + (at-end (previous-single-property-change (1- (point)) 'slime-repl-old-output)))) + (end (cond (at-beginning (or (next-single-property-change (point) 'slime-repl-old-output) (point-max))) + (inside (or (next-single-property-change (point) 'slime-repl-old-output) (point-max))) + (at-end (point))))) + ; (setq message (format "%s %s %s %s %s" at-beginning inside at-end start end)) + (when (and (or inside at-end) start end (> end start)) + (let ((kind (get this-command 'action-type))) + ; (message (format "%s %s %s %s" at-beginning inside at-end kind)) + (cond ((and (eq kind 'inserts) inside (not at-beginning)) + (setq this-command 'ignore-event)) + ((and (eq kind 'deletes-forward) inside (not at-end)) + (kill-region start end) + (setq this-command 'ignore-event)) + ((and (eq kind 'deletes-backward) (or inside at-end) (not at-beginning)) + (kill-region start end) + (setq this-command 'ignore-event)))))) + ) + +(defun slime-presentation-post-command-hook () + (when (null pre-command-hook) + (message "Lost the pre-command-hook. Putting it back!") ; can't seem to prevent this losing, even when trying to catch error + (add-hook 'pre-command-hook 'slime-pre-command-hook) + (add-hook 'pre-command-hook 'slime-presentation-command-hook))) + +(defun slime-copy-presentation-at-point (event) + (interactive "e") + (let* ((point (posn-point (event-end event))) + (what (get-text-property point 'slime-repl-old-output)) + (start (previous-single-property-change point 'slime-repl-old-output)) + (end (or (next-single-property-change point 'slime-repl-old-output) (point-max)))) + (when (not (string-match "\\s-" (buffer-substring (1- (point)) (point)))) + (insert " ")) + (slime-propertize-region '(face slime-repl-inputed-output-face) + (insert (buffer-substring start end))) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " ")))) + +(put 'self-insert-command 'action-type 'inserts) +(put 'self-insert-command-1 'action-type 'inserts) +(put 'yank 'action-type 'inserts) +(put 'kill-word 'action-type 'deletes-forward) +(put 'delete-char 'action-type 'deletes-forward) +(put 'kill-sexp 'action-type 'deletes-forward) +(put 'backward-kill-sexp 'action-type 'deletes-backward) +(put 'backward-delete-char 'action-type 'deletes-backward) +(put 'backward-kill-word 'action-type 'deletes-backward) +(put 'backward-delete-char-untabify 'action-type 'deletes-backward) +(put 'slime-repl-newline-and-indent 'action-type 'inserts) + + (defun slime-repl-insert-prompt (result &optional time) "Goto to point max, insert RESULT and the prompt. Set slime-output-end to start of the inserted text slime-input-start to @@ -2669,9 +2744,10 @@ (unless (string= "" result) (slime-propertize-region `(face slime-repl-result-face slime-repl-old-output ,slime-current-output-id - read-only t) - (insert result) - (unless (bolp) (insert "\n"))) + mouse-face slime-repl-output-mouseover-face + keymap (keymap (mouse-2 . slime-copy-presentation-at-point))) + (insert result)) + (unless (bolp) (insert "\n")) (let ((inhibit-read-only t)) (put-text-property (- (point) 2) (point) 'rear-nonsticky @@ -2888,7 +2964,8 @@ (save-excursion (goto-char slime-repl-input-end-mark) (recenter -1)))) - ((and (get-text-property (point) 'slime-repl-old-output) + ((and (or (get-text-property (point) 'slime-repl-old-output) + (get-text-property (1- (point)) 'slime-repl-old-output)) (< (point) slime-repl-input-start-mark)) (slime-repl-grab-old-output end-of-input) (unless (pos-visible-in-window-p slime-repl-input-end-mark) @@ -2977,12 +3054,16 @@ ;; forward one char to avoid doing the wrong thing if ;; we're at the beginning of the old input. -luke ;; (18/Jun/2004) - (ignore-errors (forward-char)) + (unless (not (get-text-property (point) 'slime-repl-old-output)) + ;alanr unless we are sitting right after it May 19, 2005 + (ignore-errors (forward-char))) (previous-single-char-property-change (point) prop))) (end (save-excursion - (goto-char (next-single-char-property-change (point) prop)) - (skip-chars-backward "\n \t\r" beg) - (point)))) + (if (get-text-property (point) 'slime-repl-old-output) + (progn (goto-char (next-single-char-property-change (point) prop)) + (skip-chars-backward "\n \t\r" beg) + (point)) + (point))))) (values beg end))) (defun slime-repl-closing-return () From aruttenberg at common-lisp.net Thu May 19 17:13:58 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Thu, 19 May 2005 19:13:58 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050519171358.12E7D8872F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3726/slime Modified Files: ChangeLog Log Message: Date: Thu May 19 19:13:58 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.688 slime/ChangeLog:1.689 --- slime/ChangeLog:1.688 Thu May 19 04:24:13 2005 +++ slime/ChangeLog Thu May 19 19:13:58 2005 @@ -1,3 +1,17 @@ +2005-05-19 Alan Ruttenberg + + * slime.el (slime-presentation-command-hook) new function for + nicer behaviour for presentations. + (slime-pre-command-hook) do slime-presentation-command-hook + (slime-post-command-hook) put pre-command-hook back if goes away + (slime-copy-presentation-at-point) mouse-2 copies previous output to point + slime-repl-output-mouseover-face what the old output looks like when the mouse moves over it + default: box around it like on lispm + (slime-repl-insert-prompt) add mouseover face, mouse action. newline after output not propertized. + (slime-property-bounds) adjust for lack of propertized newline + to fix: presentation region behaviour should be attach to generic property like + (:acts-as-token t ) rather than tying to repl-output property + 2005-05-19 Luke Gorrie * swank.lisp (*record-repl-results*): Variable to enable/disable From lgorrie at common-lisp.net Fri May 20 05:41:46 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 20 May 2005 07:41:46 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050520054146.8E0FC88741@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17354 Modified Files: swank.lisp Log Message: (clear-repl-results): Fixed unbalanced parens. Thanks Lawrence Mitchell. Date: Fri May 20 07:41:45 2005 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.300 slime/swank.lisp:1.301 --- slime/swank.lisp:1.300 Thu May 19 04:15:10 2005 +++ slime/swank.lisp Fri May 20 07:41:45 2005 @@ -1873,7 +1873,7 @@ (defslimefun clear-repl-results () "Forget the results of all previous REPL evaluations." - (setf *repl-results* '())) + (setf *repl-results* '()) t) (defslimefun ed-in-emacs (&optional what) From lgorrie at common-lisp.net Fri May 20 05:42:07 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 20 May 2005 07:42:07 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050520054207.86DD688753@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17385 Modified Files: ChangeLog Log Message: Date: Fri May 20 07:42:07 2005 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.689 slime/ChangeLog:1.690 --- slime/ChangeLog:1.689 Thu May 19 19:13:58 2005 +++ slime/ChangeLog Fri May 20 07:42:06 2005 @@ -1,3 +1,8 @@ +2005-05-20 Luke Gorrie + + * swank.lisp (clear-repl-results): Fixed unbalanced parens. Thanks + Lawrence Mitchell. + 2005-05-19 Alan Ruttenberg * slime.el (slime-presentation-command-hook) new function for From aruttenberg at common-lisp.net Fri May 20 12:55:29 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 20 May 2005 14:55:29 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050520125529.6F5898874D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10870/slime Modified Files: slime.el Log Message: Date: Fri May 20 14:55:28 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.492 slime/slime.el:1.493 --- slime/slime.el:1.492 Thu May 19 19:06:13 2005 +++ slime/slime.el Fri May 20 14:55:28 2005 @@ -2732,6 +2732,8 @@ (put 'backward-delete-char-untabify 'action-type 'deletes-backward) (put 'slime-repl-newline-and-indent 'action-type 'inserts) +(defvar slime-presentation-map (make-sparse-keymap)) +(define-key slime-presentation-map [mouse-2] 'slime-copy-presentation-at-point) (defun slime-repl-insert-prompt (result &optional time) "Goto to point max, insert RESULT and the prompt. Set @@ -2745,7 +2747,7 @@ (slime-propertize-region `(face slime-repl-result-face slime-repl-old-output ,slime-current-output-id mouse-face slime-repl-output-mouseover-face - keymap (keymap (mouse-2 . slime-copy-presentation-at-point))) + keymap ,slime-presentation-map) (insert result)) (unless (bolp) (insert "\n")) (let ((inhibit-read-only t)) From aruttenberg at common-lisp.net Fri May 20 12:55:55 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 20 May 2005 14:55:55 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050520125555.7ACC18874E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10899/slime Modified Files: ChangeLog Log Message: Date: Fri May 20 14:55:54 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.690 slime/ChangeLog:1.691 --- slime/ChangeLog:1.690 Fri May 20 07:42:06 2005 +++ slime/ChangeLog Fri May 20 14:55:54 2005 @@ -1,3 +1,7 @@ +2005-05-19 Alan Ruttenberg + + * slime.el slime-presentation-map + 2005-05-20 Luke Gorrie * swank.lisp (clear-repl-results): Fixed unbalanced parens. Thanks From aruttenberg at common-lisp.net Fri May 20 18:02:59 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 20 May 2005 20:02:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050520180259.EC3C488750@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31673/slime Modified Files: slime.el Log Message: Date: Fri May 20 20:02:55 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.493 slime/slime.el:1.494 --- slime/slime.el:1.493 Fri May 20 14:55:28 2005 +++ slime/slime.el Fri May 20 20:02:55 2005 @@ -366,6 +366,11 @@ "Face for the prompt in the SLIME REPL." :group 'slime-repl) +(defcustom slime-repl-enable-presentations nil + "Should we enable presentations" + :type '(boolean) + :group 'slime-repl) + (defface slime-repl-output-face (if (slime-face-inheritance-possible-p) '((t (:inherit font-lock-string-face))) @@ -2531,6 +2536,36 @@ (with-current-buffer (process-buffer process) (slime-output-string string)))) +(pushnew '(slime-repl-old-output . t) text-property-default-nonsticky :test 'equal) +(pushnew '(slime-repl-result-face . t) text-property-default-nonsticky :test 'equal) + +(make-variable-buffer-local + (defvar slime-presentation-start-to-point (make-hash-table))) + +(defun slime-mark-presentation-start (process string) + (if (and string (string-match "<\\([0-9]+\\)" string)) + (progn + (let ((id (car (read-from-string (substring string (match-beginning 1) (match-end 1)))))) + (setf (gethash id slime-presentation-start-to-point) + (with-current-buffer (slime-output-buffer) + (marker-position (symbol-value 'slime-output-end)))))))) + +(defun slime-mark-presentation-end (process string) + (if (and string (string-match ">\\([0-9]+\\)" string)) + (progn + (let ((id (car (read-from-string (substring string (match-beginning 1) (match-end 1)))))) + (let ((start (gethash id slime-presentation-start-to-point))) + (setf (gethash id slime-presentation-start-to-point) nil) + (when start + (with-current-buffer (slime-output-buffer) + (add-text-properties start (symbol-value 'slime-output-end) + `(face slime-repl-result-face + slime-repl-old-output ,id + mouse-face slime-repl-output-mouseover-face + keymap (keymap (mouse-2 . slime-copy-presentation-at-point)) + rear-nonsticky (slime-repl-old-output slime-repl-result-face slime-repl-output-mouseover-face ))) + ))))))) + (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" (slime-with-connection-buffer () @@ -2539,9 +2574,19 @@ (when slime-kill-without-query-p (process-kill-without-query stream)) (set-process-filter stream 'slime-output-filter) - (set-process-coding-system stream - slime-net-coding-system - slime-net-coding-system) + (when slime-repl-enable-presentations + (require 'bridge) + (defun bridge-insert (process output) + (slime-output-filter process (or output ""))) + (install-bridge) + (setq bridge-destination-insert nil) + (setq bridge-source-insert nil) + (setq bridge-handlers (list* '("<" . slime-mark-presentation-start) + '(">" . slime-mark-presentation-end) + bridge-handlers)) + (set-process-coding-system stream + slime-net-coding-system + slime-net-coding-system)) (when-let (secret (slime-secret)) (slime-net-send secret stream)) stream)) @@ -2713,12 +2758,19 @@ (what (get-text-property point 'slime-repl-old-output)) (start (previous-single-property-change point 'slime-repl-old-output)) (end (or (next-single-property-change point 'slime-repl-old-output) (point-max)))) - (when (not (string-match "\\s-" (buffer-substring (1- (point)) (point)))) - (insert " ")) - (slime-propertize-region '(face slime-repl-inputed-output-face) - (insert (buffer-substring start end))) - (when (and (not (eolp)) (not (looking-at "\\s-"))) - (insert " ")))) + (flet ((do-insertion () + (when (not (string-match "\\s-" (buffer-substring (1- (point)) (point)))) + (insert " ")) + (slime-propertize-region '(face slime-repl-inputed-output-face) + (insert (buffer-substring start end))) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " ")))) + (if (>= (point) slime-repl-prompt-start-mark) + (do-insertion) + (save-excursion + (goto-char (point-max)) + (do-insertion) + ))))) (put 'self-insert-command 'action-type 'inserts) (put 'self-insert-command-1 'action-type 'inserts) @@ -2744,11 +2796,14 @@ (let ((start (point))) (unless (bolp) (insert "\n")) (unless (string= "" result) - (slime-propertize-region `(face slime-repl-result-face - slime-repl-old-output ,slime-current-output-id - mouse-face slime-repl-output-mouseover-face - keymap ,slime-presentation-map) - (insert result)) + (slime-propertize-region `(face slime-repl-result-face) + (slime-propertize-region + (and slime-repl-enable-presentations + `(face slime-repl-result-face + slime-repl-old-output ,(- slime-current-output-id) + mouse-face slime-repl-output-mouseover-face + keymap ,slime-presentation-map)) + (insert result))) (unless (bolp) (insert "\n")) (let ((inhibit-read-only t)) (put-text-property (- (point) 2) (point) From aruttenberg at common-lisp.net Fri May 20 18:04:13 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 20 May 2005 20:04:13 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/bridge.el Message-ID: <20050520180413.0E4FD88752@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31714 Added Files: bridge.el Log Message: >From ilisp Date: Fri May 20 20:04:12 2005 Author: aruttenberg From aruttenberg at common-lisp.net Fri May 20 18:04:48 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 20 May 2005 20:04:48 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050520180448.DDAFC88754@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31737 Added Files: present.lisp Log Message: Date: Fri May 20 20:04:48 2005 Author: aruttenberg From aruttenberg at common-lisp.net Fri May 20 18:05:06 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 20 May 2005 20:05:06 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050520180506.4EEBE88754@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31754 Modified Files: ChangeLog Log Message: Date: Fri May 20 20:05:05 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.691 slime/ChangeLog:1.692 --- slime/ChangeLog:1.691 Fri May 20 14:55:54 2005 +++ slime/ChangeLog Fri May 20 20:05:05 2005 @@ -1,3 +1,21 @@ +2005-05-20 Alan Ruttenberg + * bridge.el new file. from ilisp cvs distribution to collect in-band messages using + process filter mechanisms. One edit which calls bridge-insert with process argument + as well as output + * present.lisp new file. Enough code to do the following: + (swank::presenting-object object stream (print "This is really object")). This + makes the string "This is really object" behave like old repl input for the object. + Sample code for openmcl and cmucl that hooks this into the printing of unreadable objects + This should be part of swank.lisp (and lisp specific files) but I am too chicken to + merge yet. For now you have to load this file manually. + * slime.el changes to support above: + slime-repl-enable-presentations: customize to enable this stuff. Default value t. + Set to nil to turn it off. + slime-presentation-start-to-point: map object ids to the (point) where they start to print out. + slime-mark-presentation-start, slime-mark-presentation-end. handlers for the + bridge messages. + slime-open-stream-to-lisp: When enabled start the bridge and define the handlers. + 2005-05-19 Alan Ruttenberg * slime.el slime-presentation-map From aruttenberg at common-lisp.net Fri May 20 18:05:50 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Fri, 20 May 2005 20:05:50 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050520180550.8075588754@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31774 Modified Files: slime.el Log Message: Date: Fri May 20 20:05:50 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.494 slime/slime.el:1.495 --- slime/slime.el:1.494 Fri May 20 20:02:55 2005 +++ slime/slime.el Fri May 20 20:05:49 2005 @@ -366,7 +366,7 @@ "Face for the prompt in the SLIME REPL." :group 'slime-repl) -(defcustom slime-repl-enable-presentations nil +(defcustom slime-repl-enable-presentations t "Should we enable presentations" :type '(boolean) :group 'slime-repl) From lgorrie at common-lisp.net Fri May 20 19:16:40 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 20 May 2005 21:16:40 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050520191640.889F188758@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3877 Modified Files: slime.el Log Message: (slime-repl-enable-presentations): Default is enabled in GNU Emacs but disabled in XEmacs. Feature is not portable yet. Brutally 80-column'ified alanr's latest changes :-) Date: Fri May 20 21:16:40 2005 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.495 slime/slime.el:1.496 --- slime/slime.el:1.495 Fri May 20 20:05:49 2005 +++ slime/slime.el Fri May 20 21:16:39 2005 @@ -366,7 +366,7 @@ "Face for the prompt in the SLIME REPL." :group 'slime-repl) -(defcustom slime-repl-enable-presentations t +(defcustom slime-repl-enable-presentations (not (featurep 'xemacs)) "Should we enable presentations" :type '(boolean) :group 'slime-repl) @@ -2536,8 +2536,13 @@ (with-current-buffer (process-buffer process) (slime-output-string string)))) -(pushnew '(slime-repl-old-output . t) text-property-default-nonsticky :test 'equal) -(pushnew '(slime-repl-result-face . t) text-property-default-nonsticky :test 'equal) +;; FIXME: This conditional is not right - just used because the code +;; here does not work in XEmacs. +(when slime-repl-enable-presentations + (pushnew '(slime-repl-old-output . t) text-property-default-nonsticky + :test 'equal) + (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky + :test 'equal)) (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) @@ -2545,7 +2550,8 @@ (defun slime-mark-presentation-start (process string) (if (and string (string-match "<\\([0-9]+\\)" string)) (progn - (let ((id (car (read-from-string (substring string (match-beginning 1) (match-end 1)))))) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) (setf (gethash id slime-presentation-start-to-point) (with-current-buffer (slime-output-buffer) (marker-position (symbol-value 'slime-output-end)))))))) @@ -2553,18 +2559,21 @@ (defun slime-mark-presentation-end (process string) (if (and string (string-match ">\\([0-9]+\\)" string)) (progn - (let ((id (car (read-from-string (substring string (match-beginning 1) (match-end 1)))))) + (let* ((match (substring string (match-beginning 1) (match-end 1))) + (id (car (read-from-string match)))) (let ((start (gethash id slime-presentation-start-to-point))) (setf (gethash id slime-presentation-start-to-point) nil) (when start (with-current-buffer (slime-output-buffer) - (add-text-properties start (symbol-value 'slime-output-end) - `(face slime-repl-result-face - slime-repl-old-output ,id - mouse-face slime-repl-output-mouseover-face - keymap (keymap (mouse-2 . slime-copy-presentation-at-point)) - rear-nonsticky (slime-repl-old-output slime-repl-result-face slime-repl-output-mouseover-face ))) - ))))))) + (add-text-properties + start (symbol-value 'slime-output-end) + `(face slime-repl-result-face + slime-repl-old-output ,id + mouse-face slime-repl-output-mouseover-face + keymap (keymap (mouse-2 . slime-copy-presentation-at-point)) + rear-nonsticky (slime-repl-old-output + slime-repl-result-face + slime-repl-output-mouseover-face)))))))))) (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" @@ -2757,9 +2766,11 @@ (let* ((point (posn-point (event-end event))) (what (get-text-property point 'slime-repl-old-output)) (start (previous-single-property-change point 'slime-repl-old-output)) - (end (or (next-single-property-change point 'slime-repl-old-output) (point-max)))) + (end (or (next-single-property-change point 'slime-repl-old-output) + (point-max)))) (flet ((do-insertion () - (when (not (string-match "\\s-" (buffer-substring (1- (point)) (point)))) + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) (insert " ")) (slime-propertize-region '(face slime-repl-inputed-output-face) (insert (buffer-substring start end))) @@ -2769,8 +2780,7 @@ (do-insertion) (save-excursion (goto-char (point-max)) - (do-insertion) - ))))) + (do-insertion)))))) (put 'self-insert-command 'action-type 'inserts) (put 'self-insert-command-1 'action-type 'inserts) From lgorrie at common-lisp.net Fri May 20 19:21:41 2005 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 20 May 2005 21:21:41 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050520192141.D7A1788758@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3919 Modified Files: ChangeLog Log Message: Date: Fri May 20 21:21:41 2005 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.692 slime/ChangeLog:1.693 --- slime/ChangeLog:1.692 Fri May 20 20:05:05 2005 +++ slime/ChangeLog Fri May 20 21:21:41 2005 @@ -1,20 +1,32 @@ +2005-05-20 Luke Gorrie + + * slime.el (slime-repl-enable-presentations): Default is enabled + in GNU Emacs but disabled in XEmacs. Feature is not portable yet. + Brutally 80-column'ified alanr's latest changes :-) + 2005-05-20 Alan Ruttenberg - * bridge.el new file. from ilisp cvs distribution to collect in-band messages using - process filter mechanisms. One edit which calls bridge-insert with process argument - as well as output + + * bridge.el new file. from ilisp cvs distribution to collect + in-band messages using process filter mechanisms. One edit which + calls bridge-insert with process argument as well as output + * present.lisp new file. Enough code to do the following: - (swank::presenting-object object stream (print "This is really object")). This - makes the string "This is really object" behave like old repl input for the object. - Sample code for openmcl and cmucl that hooks this into the printing of unreadable objects - This should be part of swank.lisp (and lisp specific files) but I am too chicken to - merge yet. For now you have to load this file manually. - * slime.el changes to support above: - slime-repl-enable-presentations: customize to enable this stuff. Default value t. - Set to nil to turn it off. - slime-presentation-start-to-point: map object ids to the (point) where they start to print out. - slime-mark-presentation-start, slime-mark-presentation-end. handlers for the - bridge messages. - slime-open-stream-to-lisp: When enabled start the bridge and define the handlers. + (swank::presenting-object object stream (print "This is really + object")). This makes the string "This is really object" behave + like old repl input for the object. Sample code for openmcl and + cmucl that hooks this into the printing of unreadable objects This + should be part of swank.lisp (and lisp specific files) but I am + too chicken to merge yet. For now you have to load this file + manually. + + * slime.el changes to support above: + slime-repl-enable-presentations: customize to enable this stuff. + Default value t. Set to nil to turn it off. + slime-presentation-start-to-point: map object ids to the (point) + where they start to print out. slime-mark-presentation-start, + slime-mark-presentation-end. handlers for the bridge messages. + slime-open-stream-to-lisp: When enabled start the bridge and + define the handlers. 2005-05-19 Alan Ruttenberg From aruttenberg at common-lisp.net Sat May 21 05:04:04 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sat, 21 May 2005 07:04:04 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050521050404.1BFD688759@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7091/slime Modified Files: swank.lisp Log Message: Date: Sat May 21 07:04:03 2005 Author: aruttenberg Index: slime/swank.lisp diff -u slime/swank.lisp:1.301 slime/swank.lisp:1.302 --- slime/swank.lisp:1.301 Fri May 20 07:41:45 2005 +++ slime/swank.lisp Sat May 21 07:04:02 2005 @@ -1858,10 +1858,10 @@ (defslimefun get-repl-result (id) "Get the result of the previous REPL evaluation with ID." - (let ((previous-output (assoc id *repl-results*))) + (let ((previous-output (assoc (- id) *repl-results*))) (when (null previous-output) (if *record-repl-results* - (error "Attempt to access no longer existing result (number ~D)." id) + (error "Attempt to access no longer existing result (number ~D)." (- id)) (error "Attempt to access unrecorded result (number ~D). ~&See ~S." id '*record-repl-results*))) (cdr previous-output))) From aruttenberg at common-lisp.net Sat May 21 05:04:34 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sat, 21 May 2005 07:04:34 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050521050434.7647F8875D@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7111/slime Modified Files: ChangeLog Log Message: Date: Sat May 21 07:04:33 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.693 slime/ChangeLog:1.694 --- slime/ChangeLog:1.693 Fri May 20 21:21:41 2005 +++ slime/ChangeLog Sat May 21 07:04:33 2005 @@ -1,3 +1,7 @@ +2005-05-20 Alan Ruttenberg + * swank.lisp make repl output presentation work even if + present.lisp not loaded + 2005-05-20 Luke Gorrie * slime.el (slime-repl-enable-presentations): Default is enabled From aruttenberg at common-lisp.net Sun May 22 06:52:17 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 22 May 2005 08:52:17 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050522065217.6234A88753@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1035/slime Modified Files: ChangeLog Log Message: Date: Sun May 22 08:52:14 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.694 slime/ChangeLog:1.695 --- slime/ChangeLog:1.694 Sat May 21 07:04:33 2005 +++ slime/ChangeLog Sun May 22 08:52:13 2005 @@ -1,4 +1,14 @@ 2005-05-20 Alan Ruttenberg + + * present.lisp. mouse-3 now gives a menu for actions on the + presentation. See documentation in file for information about how + to define menus. Also, disable presentations in inspector. Initial bits + of dealing with the possibility of presenting readable objects. + + * slime.el support menu. Xemacs users beware this uses x-popup-menu, + which may be fsf specific. + +2005-05-20 Alan Ruttenberg * swank.lisp make repl output presentation work even if present.lisp not loaded From aruttenberg at common-lisp.net Sun May 22 06:55:05 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 22 May 2005 08:55:05 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050522065505.96A9A88762@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1075/slime Modified Files: slime.el Log Message: Date: Sun May 22 08:55:04 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.496 slime/slime.el:1.497 --- slime/slime.el:1.496 Fri May 20 21:16:39 2005 +++ slime/slime.el Sun May 22 08:55:04 2005 @@ -2570,7 +2570,7 @@ `(face slime-repl-result-face slime-repl-old-output ,id mouse-face slime-repl-output-mouseover-face - keymap (keymap (mouse-2 . slime-copy-presentation-at-point)) + keymap ,slime-presentation-map rear-nonsticky (slime-repl-old-output slime-repl-result-face slime-repl-output-mouseover-face)))))))))) @@ -2752,8 +2752,13 @@ (setq this-command 'ignore-event)) ((and (eq kind 'deletes-backward) (or inside at-end) (not at-beginning)) (kill-region start end) - (setq this-command 'ignore-event)))))) - ) + (setq this-command 'ignore-event)) + ((eq kind 'copies) ; need to handle removing properties when only a portion is copied. This doesn't do it. + (multiple-value-bind (start end) (slime-property-bounds 'slime-repl-old-input) + (let ((length (abs (- start end)))) + ;(message (format "%s %s" length (abs (- (point) (mark)))))))) + )))))))) + (defun slime-presentation-post-command-hook () (when (null pre-command-hook) @@ -2793,9 +2798,36 @@ (put 'backward-kill-word 'action-type 'deletes-backward) (put 'backward-delete-char-untabify 'action-type 'deletes-backward) (put 'slime-repl-newline-and-indent 'action-type 'inserts) +(put 'kill-ring-save 'action-type 'copies) (defvar slime-presentation-map (make-sparse-keymap)) (define-key slime-presentation-map [mouse-2] 'slime-copy-presentation-at-point) +(define-key slime-presentation-map [mouse-3] 'slime-presentation-menu) + +;; protocol for handling up a menu. +;; 1. Send lisp message asking for menu choices for this object. Get back list of strings. +;; 2. Let used choose +;; 3. Call back to execute menu choice, passing nth and string of choice +;; 4. Call eval on return value + +(defun slime-presentation-menu (event) + (interactive "e") + (let* ((point (posn-point (event-end event))) + (what (get-text-property point 'slime-repl-old-output)) + (choices (slime-eval `(swank::menu-choices-for-presentation-id ,what))) + (count 0)) + (when choices + (if (symbolp choices) + (x-popup-menu event `("Object no longer recorded" ("sorry" nil))) + (let ((choice + (x-popup-menu event + `("" ("" ,@(mapcar + (lambda(choice) + (cons choice (incf count))) + choices)))))) + (when choice + (eval (slime-eval `(swank::execute-menu-choice-for-presentation-id ,what ,choice ,(nth (1- choice) choices)))))))))) + (defun slime-repl-insert-prompt (result &optional time) "Goto to point max, insert RESULT and the prompt. Set @@ -7536,6 +7568,9 @@ (defvar slime-inspector-mark-stack '()) (defvar slime-saved-window-config) + +(defun slime-inspect-presented-object (id) + (slime-inspect `(swank::init-inspector ,(format "(swank::lookup-presented-object %s)" id)))) (defun slime-inspect (form) "Eval an expression and inspect the result." From aruttenberg at common-lisp.net Sun May 22 06:55:59 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 22 May 2005 08:55:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050522065559.02B6E88764@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1115/slime Modified Files: present.lisp Log Message: Date: Sun May 22 08:55:59 2005 Author: aruttenberg Index: slime/present.lisp diff -u slime/present.lisp:1.1 slime/present.lisp:1.2 --- slime/present.lisp:1.1 Fri May 20 20:04:48 2005 +++ slime/present.lisp Sun May 22 08:55:59 2005 @@ -9,7 +9,16 @@ ;; and adds the necessary text properties to the output. (defvar *can-print-presentation* nil - "set this to t in contexts where it is ok to print presentations") + "set this to t in contexts where it is ok to print presentations at all") + +(defvar *can-present-readable-objects* nil + "set this to t in context where it is ok to automatically print presentations +for some subset of readable objects, such as pathnames. Generally, this is unsafe +(since you might not be printing to the listener and expecting to read +them later) but can be appropriate in specific circumstances, such as +when you know your output is going to the listener, or where you know +you wouldn't be later reading the objects printed" + ) (defvar *object-to-presentation-id* (make-hash-table :test 'eq #+openmcl :weak #+openmcl :key) "Store the mapping of objects to numeric identifiers") @@ -22,6 +31,7 @@ (defun clear-presentation-tables () (clrhash *object-to-presentation-id*) (clrhash *presentation-id-to-object*) + (setq *presentation-counter* 0) ) (defun lookup-presented-object (id) @@ -42,6 +52,19 @@ be sensitive and remember what object it is in the repl" `(presenting-object-1 ,object ,stream #'(lambda () , at body))) +(defmacro presenting-object-if (predicate object stream &body body) + "What you use in your code. Wrap this around some printing and that text will +be sensitive and remember what object it is in the repl if predicate is true" + (let ((continue (gensym))) + `(let ((,continue #'(lambda () , at body))) + (if ,predicate + (presenting-object-1 ,object ,stream ,continue) + (funcall ,continue))))) + +(defun can-present-readable-objects (&optional stream) + (declare (ignore stream)) + *can-present-readable-objects*) + (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and ) (pp-end-block stream ">")) - nil))) + nil)) + ;(defmethod print-object :around ((pathname pathname) stream) + ; (swank::presenting-object-if (swank::can-present-readable-objects stream) pathname stream (call-next-method))) +) #+openmcl (ccl::def-load-pointers clear-presentations () From aruttenberg at common-lisp.net Mon May 23 02:31:14 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Mon, 23 May 2005 04:31:14 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050523023114.14533880DF@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7098 Modified Files: ChangeLog Log Message: Date: Mon May 23 04:31:14 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.695 slime/ChangeLog:1.696 --- slime/ChangeLog:1.695 Sun May 22 08:52:13 2005 +++ slime/ChangeLog Mon May 23 04:31:12 2005 @@ -1,5 +1,22 @@ 2005-05-20 Alan Ruttenberg + * present.lisp. (slime-stream-p) check if a stream is destined for + output in a slime listener. (checks *connections* looks into pretty-print + streams in openmcl and cmucl) + Don't present unless (slime-stream-p stream). + + Variable *enable-presenting-readable-objects* The only readable object + which is presented are pathnames (e.g. pathnames printed when loading + and *load-verbose* is t). Try the useful menu :) + More to come if this doesn't cause problems. (nil this if it does) + + *can-print-presentation* t around compile-string-for-emacs, + load-file, interactive-eval. + + In cmucl, use fwrappers to modify behaviour rather than redefinition. + +2005-05-20 Alan Ruttenberg + * present.lisp. mouse-3 now gives a menu for actions on the presentation. See documentation in file for information about how to define menus. Also, disable presentations in inspector. Initial bits From aruttenberg at common-lisp.net Mon May 23 02:32:28 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Mon, 23 May 2005 04:32:28 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050523023228.215FB886FB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7122 Modified Files: present.lisp Log Message: Date: Mon May 23 04:32:27 2005 Author: aruttenberg Index: slime/present.lisp diff -u slime/present.lisp:1.2 slime/present.lisp:1.3 --- slime/present.lisp:1.2 Sun May 22 08:55:59 2005 +++ slime/present.lisp Mon May 23 04:32:27 2005 @@ -8,18 +8,21 @@ ;; given id and another when we are done. The process filter notices these ;; and adds the necessary text properties to the output. +;; We only do this if we know we are printing to a slime stream, +;; checked with the method slime-stream-p. Initially this checks for +;; the knows slime streams looking at *connections*. In cmucl and +;; openmcl it also checks if it is a pretty-printing stream which +;; ultimately prints to a slime stream. + +;; Control (defvar *can-print-presentation* nil "set this to t in contexts where it is ok to print presentations at all") -(defvar *can-present-readable-objects* nil - "set this to t in context where it is ok to automatically print presentations -for some subset of readable objects, such as pathnames. Generally, this is unsafe -(since you might not be printing to the listener and expecting to read -them later) but can be appropriate in specific circumstances, such as -when you know your output is going to the listener, or where you know -you wouldn't be later reading the objects printed" - ) +(defvar *enable-presenting-readable-objects* t + "set this to enable automatically printing presentations for some +subset of readable objects, such as pathnames." ) +;; Saving presentations (defvar *object-to-presentation-id* (make-hash-table :test 'eq #+openmcl :weak #+openmcl :key) "Store the mapping of objects to numeric identifiers") @@ -31,7 +34,6 @@ (defun clear-presentation-tables () (clrhash *object-to-presentation-id*) (clrhash *presentation-id-to-object*) - (setq *presentation-counter* 0) ) (defun lookup-presented-object (id) @@ -47,6 +49,8 @@ (setf (gethash object *object-to-presentation-id*) newid) newid))) +;; doing it + (defmacro presenting-object (object stream &body body) "What you use in your code. Wrap this around some printing and that text will be sensitive and remember what object it is in the repl" @@ -61,14 +65,31 @@ (presenting-object-1 ,object ,stream ,continue) (funcall ,continue))))) +(defmethod slime-stream-p (stream) + "Check if stream is one of the slime streams, since if it isnt' we +don't want to present anything" + (or #+openmcl + (and (typep stream 'ccl::xp-stream) + ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) + (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) + #+cmu + (and (typep stream 'pretty-print::pretty-stream) + (slime-stream-p (pretty-print::pretty-stream-target stream))) + (loop for connection in *connections* + thereis (or (eq stream (connection.dedicated-output connection)) + (eq stream (connection.socket-io connection)) + (eq stream (connection.user-output connection)) + (eq stream (connection.user-io connection)))))) + (defun can-present-readable-objects (&optional stream) (declare (ignore stream)) - *can-present-readable-objects*) + *enable-presenting-readable-objects*) (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and ) (pp-end-block stream ">")) nil)) - ;(defmethod print-object :around ((pathname pathname) stream) - ; (swank::presenting-object-if (swank::can-present-readable-objects stream) pathname stream (call-next-method))) -) + (defmethod print-object :around ((pathname pathname) stream) + (swank::presenting-object-if + (swank::can-present-readable-objects stream) + pathname stream (call-next-method)))) #+openmcl (ccl::def-load-pointers clear-presentations () (swank::clear-presentation-tables)) -#+cmu -(in-package :lisp) +(in-package :swank) #+cmu -(ext:without-package-locks - (defun %print-unreadable-object (object stream type identity body) - (when *print-readably* - (error 'print-not-readable :object object)) - (flet ((print-description () - (when type - (write (type-of object) :stream stream :circle nil - :level nil :length nil) - (when (or body identity) - (write-char #\space stream) - (pprint-newline :fill stream))) - (when body - (funcall body)) - (when identity - (when body - (write-char #\space stream) - (pprint-newline :fill stream)) - (write-char #\{ stream) - (write (get-lisp-obj-address object) :stream stream - :radix nil :base 16) - (write-char #\} stream)))) - (swank::presenting-object object stream - (cond ((and (pp:pretty-stream-p stream) *print-pretty*) - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (print-description))) - (t - (write-string "#<" stream) - (print-description) - (write-char #\> stream)))) - nil))) \ No newline at end of file +(progn + (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) + (presenting-object object stream + (fwrappers:call-next-function))) + + (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) + (presenting-object-if (can-present-readable-objects stream) pathname stream + (fwrappers:call-next-function))) + + (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) + (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper) + ) From aruttenberg at common-lisp.net Tue May 24 02:40:55 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 24 May 2005 04:40:55 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050524024055.02D4E88704@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29926 Modified Files: ChangeLog Log Message: Date: Tue May 24 04:40:55 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.696 slime/ChangeLog:1.697 --- slime/ChangeLog:1.696 Mon May 23 04:31:12 2005 +++ slime/ChangeLog Tue May 24 04:40:55 2005 @@ -1,5 +1,15 @@ 2005-05-20 Alan Ruttenberg + * slime.el slime-presentation-menu - use with-current-buffer, so + that menus work even if you are not in the buffer with the + presentation. + + * present.lisp More menu items for pathnames. Remember last + slime-stream-p value. *can-print-presentation* t during + swank-compiler and during presentation menu action. + +2005-05-20 Alan Ruttenberg + * present.lisp. (slime-stream-p) check if a stream is destined for output in a slime listener. (checks *connections* looks into pretty-print streams in openmcl and cmucl) From aruttenberg at common-lisp.net Tue May 24 02:41:37 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 24 May 2005 04:41:37 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050524024137.2CF108871A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29956 Modified Files: slime.el Log Message: Date: Tue May 24 04:41:36 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.497 slime/slime.el:1.498 --- slime/slime.el:1.497 Sun May 22 08:55:04 2005 +++ slime/slime.el Tue May 24 04:41:36 2005 @@ -2813,20 +2813,24 @@ (defun slime-presentation-menu (event) (interactive "e") (let* ((point (posn-point (event-end event))) - (what (get-text-property point 'slime-repl-old-output)) - (choices (slime-eval `(swank::menu-choices-for-presentation-id ,what))) - (count 0)) - (when choices - (if (symbolp choices) - (x-popup-menu event `("Object no longer recorded" ("sorry" nil))) - (let ((choice - (x-popup-menu event - `("" ("" ,@(mapcar - (lambda(choice) - (cons choice (incf count))) - choices)))))) - (when choice - (eval (slime-eval `(swank::execute-menu-choice-for-presentation-id ,what ,choice ,(nth (1- choice) choices)))))))))) + (window (caadr event))) + (with-current-buffer (window-buffer window) + (let* ((what (get-text-property point 'slime-repl-old-output)) + (choices (slime-eval `(swank::menu-choices-for-presentation-id ,what))) + (count 0)) + (when choices + (if (symbolp choices) + (x-popup-menu event `("Object no longer recorded" ("sorry" nil))) + (let ((choice + (x-popup-menu event + `("" ("" ,@(mapcar + (lambda(choice) + (cons choice (incf count))) + choices)))))) + (when choice + (eval (slime-eval + `(swank::execute-menu-choice-for-presentation-id + ,what ,choice ,(nth (1- choice) choices)))))))))))) (defun slime-repl-insert-prompt (result &optional time) From aruttenberg at common-lisp.net Tue May 24 02:42:02 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 24 May 2005 04:42:02 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/present.lisp Message-ID: <20050524024202.373C88871A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29974 Modified Files: present.lisp Log Message: Date: Tue May 24 04:42:01 2005 Author: aruttenberg Index: slime/present.lisp diff -u slime/present.lisp:1.3 slime/present.lisp:1.4 --- slime/present.lisp:1.3 Mon May 23 04:32:27 2005 +++ slime/present.lisp Tue May 24 04:42:01 2005 @@ -65,21 +65,30 @@ (presenting-object-1 ,object ,stream ,continue) (funcall ,continue))))) -(defmethod slime-stream-p (stream) - "Check if stream is one of the slime streams, since if it isnt' we +(let ((last-stream nil) + (last-answer nil)) + (defmethod slime-stream-p (stream) + "Check if stream is one of the slime streams, since if it isn't we don't want to present anything" - (or #+openmcl - (and (typep stream 'ccl::xp-stream) - ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) - (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) - #+cmu - (and (typep stream 'pretty-print::pretty-stream) - (slime-stream-p (pretty-print::pretty-stream-target stream))) - (loop for connection in *connections* - thereis (or (eq stream (connection.dedicated-output connection)) - (eq stream (connection.socket-io connection)) - (eq stream (connection.user-output connection)) - (eq stream (connection.user-io connection)))))) + (if (eq last-stream stream) + last-answer + (progn + (setq last-stream stream) + (if (eq stream t) + (setq stream *standard-output*)) + (setq last-answer + (or #+openmcl + (and (typep stream 'ccl::xp-stream) + ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) + (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) + #+cmu + (and (typep stream 'pretty-print::pretty-stream) + (slime-stream-p (pretty-print::pretty-stream-target stream))) + (loop for connection in *connections* + thereis (or (eq stream (connection.dedicated-output connection)) + (eq stream (connection.socket-io connection)) + (eq stream (connection.user-output connection)) + (eq stream (connection.user-io connection)))))))))) (defun can-present-readable-objects (&optional stream) (declare (ignore stream)) @@ -94,10 +103,11 @@ (write-string "<" stream) (prin1 pid stream) (write-string "" stream) - (funcall continue) - (write-string ">" stream) - (prin1 pid stream) - (write-string "" stream)) + (multiple-value-prog1 + (funcall continue) + (write-string ">" stream) + (prin1 pid stream) + (write-string "" stream))) (funcall continue))) ;; enable presentations inside listener eval, when compiling, when evaluating @@ -188,6 +198,17 @@ (reset-inspector) (inspect-object (eval (read-from-string string)))))) +;; for load system etc +(defun swank-compiler (function) + (let ((*can-print-presentation* t)) + (clear-compiler-notes) + (with-simple-restart (abort "Abort SLIME compilation.") + (multiple-value-bind (result usecs) + (handler-bind ((compiler-condition #'record-note-for-condition)) + (measure-time-interval function)) + (list (to-string result) + (format nil "~,2F" (/ usecs 1000000.0))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; menu protocol ;; @@ -232,7 +253,9 @@ "Bug: Execute menu call for id ~a but menu has id ~a" id (car *presentation-active-menu*)) (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) - (swank-ioify (funcall action item ob id))))) + (swank-ioify + (let ((*can-print-presentation* t)) + (funcall action item ob id)))))) ;; Default method (defmethod menu-choices-for-presentation (ob) @@ -252,22 +275,54 @@ (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) (let ((source (merge-pathnames ".lisp" ob))) (and (ignore-errors (probe-file source)) - source))))) + source)))) + (fasl-file (and file-exists + (equal (ignore-errors + (namestring + (truename + (compile-file-pathname + (merge-pathnames ".lisp" ob))))) + (namestring (truename ob)))))) (remove nil (list* - (and file-exists + (and (and file-exists (not fasl-file)) (list "Edit this file" (lambda(choice object id) - (declare (ignore choice id)) `(find-file ,(namestring (truename object))) ))) + (declare (ignore choice id)) + `(find-file ,(namestring (truename object)))))) (and file-exists (list "Dired containing directory" (lambda (choice object id) (declare (ignore choice id)) - `(dired ,(namestring (truename (merge-pathnames (make-pathname :name "" :type "") object))))))) + `(dired ,(namestring + (truename + (merge-pathnames + (make-pathname :name "" :type "") object))))))) + (and fasl-file + (list "Load this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (load ob) + nil))) + (and fasl-file + (list "Delete this fasl file" + (lambda (choice object id) + (declare (ignore choice id object)) + (let ((nt (namestring (truename ob)))) + `(when (y-or-n-p ,(format nil "Delete ~a" nt)) + (delete-file ,(namestring (truename ob)))) + )))) (and source-file (list "Edit lisp source file" (lambda(choice object id) - (declare (ignore choice id object)) (ed source-file) nil))) + (declare (ignore choice id object)) + `(find-file ,(namestring (truename source-file)))))) + (and source-file + (list "Load lisp source file" + (lambda(choice object id) + (declare (ignore choice id object)) + (load source-file) + nil))) (and (next-method-p) (call-next-method)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From aruttenberg at common-lisp.net Tue May 24 07:06:35 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 24 May 2005 09:06:35 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050524070635.6737B88726@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13677 Modified Files: ChangeLog Log Message: Date: Tue May 24 09:06:34 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.697 slime/ChangeLog:1.698 --- slime/ChangeLog:1.697 Tue May 24 04:40:55 2005 +++ slime/ChangeLog Tue May 24 09:06:34 2005 @@ -1,4 +1,10 @@ -2005-05-20 Alan Ruttenberg +2005-05-24 Alan Ruttenberg + + * slime.el meta-w now removes properties before insertion if you + cut just a portion of the presentation. Added xemacs + support. Enabled in xemacs. + +2005-05-23 Alan Ruttenberg * slime.el slime-presentation-menu - use with-current-buffer, so that menus work even if you are not in the buffer with the @@ -8,7 +14,7 @@ slime-stream-p value. *can-print-presentation* t during swank-compiler and during presentation menu action. -2005-05-20 Alan Ruttenberg +2005-05-22 Alan Ruttenberg * present.lisp. (slime-stream-p) check if a stream is destined for output in a slime listener. (checks *connections* looks into pretty-print @@ -25,7 +31,7 @@ In cmucl, use fwrappers to modify behaviour rather than redefinition. -2005-05-20 Alan Ruttenberg +2005-05-22 Alan Ruttenberg * present.lisp. mouse-3 now gives a menu for actions on the presentation. See documentation in file for information about how From aruttenberg at common-lisp.net Tue May 24 07:07:13 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 24 May 2005 09:07:13 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050524070713.AF2A888736@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13706 Modified Files: slime.el Log Message: Date: Tue May 24 09:07:13 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.498 slime/slime.el:1.499 --- slime/slime.el:1.498 Tue May 24 04:41:36 2005 +++ slime/slime.el Tue May 24 09:07:12 2005 @@ -366,7 +366,7 @@ "Face for the prompt in the SLIME REPL." :group 'slime-repl) -(defcustom slime-repl-enable-presentations (not (featurep 'xemacs)) +(defcustom slime-repl-enable-presentations t; (not (featurep 'xemacs)) - alanr should work now. "Should we enable presentations" :type '(boolean) :group 'slime-repl) @@ -382,13 +382,15 @@ (defface slime-repl-output-mouseover-face - (if (slime-face-inheritance-possible-p) - '((t - (:box - (:line-width 1 :color "black" :style released-button) - :inherit - (slime-repl-inputed-output-face)))) - '((t (:box (:line-width 1 :color "black"))))) + (if (featurep 'xemacs) + '((t (:bold t))) + (if (slime-face-inheritance-possible-p) + '((t + (:box + (:line-width 1 :color "black" :style released-button) + :inherit + (slime-repl-inputed-output-face)))) + '((t (:box (:line-width 1 :color "black")))))) "Face for Lisp output in the SLIME REPL, when the mouse hovers over it" :group 'slime-repl) @@ -861,16 +863,19 @@ (when (and slime-mode (slime-connected-p)) (slime-process-available-input)) (when (null pre-command-hook) ; sometimes this is lost - (add-hook 'pre-command-hook 'slime-pre-command-hook))) + (add-hook 'pre-command-hook 'slime-pre-command-hook)) + (slime-presentation-post-command-hook) ) (defun slime-setup-command-hooks () - "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'." + "Setup a buffer-local `pre-command-h'ook' to call `slime-pre-command-hook'." (make-local-hook 'pre-command-hook) (make-local-hook 'post-command-hook) - (add-hook 'pre-command-hook 'slime-pre-command-hook) - (add-hook 'post-command-hook 'slime-post-command-hook)) + (add-hook 'pre-command-hook 'slime-pre-command-hook nil t) ; alanr: need local t + (add-hook 'post-command-hook 'slime-post-command-hook nil t)) -(add-hook 'slime-mode-hook 'slime-setup-command-hooks) +;(add-hook 'slime-mode-hook 'slime-setup-command-hooks) +;(setq post-command-hook nil) +;(setq pre-command-hook '(completion-before-command tooltip-hide)) ;;;; Framework'ey bits @@ -2727,65 +2732,83 @@ (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) +(defvar slime-not-copying-whole-presentation nil) + ;; alanr (defun slime-presentation-command-hook () (let* ((props-here (text-properties-at (point))) - (props-before (and (not (= (point) (point-min))) (text-properties-at (1- (point))))) + (props-before (and (not (= (point) (point-min))) + (text-properties-at (1- (point))))) (inside (and (getf props-here 'slime-repl-old-output))) - (at-beginning (and inside (not (getf props-before 'slime-repl-old-output)))) - (at-end (and (or (= (point) (point-max)) (not (getf props-here 'slime-repl-old-output))) + (at-beginning (and inside + (not (getf props-before 'slime-repl-old-output)))) + (at-end (and (or (= (point) (point-max)) + (not (getf props-here 'slime-repl-old-output))) (getf props-before 'slime-repl-old-output))) (start (cond (at-beginning (point)) - (inside (previous-single-property-change (point) 'slime-repl-old-output)) - (at-end (previous-single-property-change (1- (point)) 'slime-repl-old-output)))) - (end (cond (at-beginning (or (next-single-property-change (point) 'slime-repl-old-output) (point-max))) - (inside (or (next-single-property-change (point) 'slime-repl-old-output) (point-max))) + (inside (previous-single-property-change + (point) 'slime-repl-old-output)) + (at-end (previous-single-property-change + (1- (point)) 'slime-repl-old-output)))) + (end (cond (at-beginning (or (next-single-property-change + (point) 'slime-repl-old-output) + (point-max))) + (inside (or (next-single-property-change (point) 'slime-repl-old-output) + (point-max))) (at-end (point))))) ; (setq message (format "%s %s %s %s %s" at-beginning inside at-end start end)) (when (and (or inside at-end) start end (> end start)) (let ((kind (get this-command 'action-type))) ; (message (format "%s %s %s %s" at-beginning inside at-end kind)) (cond ((and (eq kind 'inserts) inside (not at-beginning)) - (setq this-command 'ignore-event)) + (setq this-command 'ignore)) ((and (eq kind 'deletes-forward) inside (not at-end)) (kill-region start end) - (setq this-command 'ignore-event)) + (setq this-command 'ignore)) ((and (eq kind 'deletes-backward) (or inside at-end) (not at-beginning)) (kill-region start end) - (setq this-command 'ignore-event)) - ((eq kind 'copies) ; need to handle removing properties when only a portion is copied. This doesn't do it. + (setq this-command 'ignore)) + ((eq kind 'copies) (multiple-value-bind (start end) (slime-property-bounds 'slime-repl-old-input) - (let ((length (abs (- start end)))) + (setq slime-not-copying-whole-presentation + (not (or (and at-beginning (>= (mark) end)) + (and at-end (<= (mark) start))))))) ;(message (format "%s %s" length (abs (- (point) (mark)))))))) - )))))))) + ))))) +;; if we did not copy the whole presentation, then remove the text properties from the +;; top of the kill ring (defun slime-presentation-post-command-hook () - (when (null pre-command-hook) - (message "Lost the pre-command-hook. Putting it back!") ; can't seem to prevent this losing, even when trying to catch error - (add-hook 'pre-command-hook 'slime-pre-command-hook) - (add-hook 'pre-command-hook 'slime-presentation-command-hook))) + (when (eq (get this-command 'action-type) 'copies) + (when slime-not-copying-whole-presentation + (remove-text-properties 0 (length (car kill-ring)) + '(slime-repl-old-output t mouse-face t rear-nonsticky t) + (car kill-ring)))) + (setq slime-not-copying-whole-presentation nil) + ) (defun slime-copy-presentation-at-point (event) (interactive "e") - (let* ((point (posn-point (event-end event))) - (what (get-text-property point 'slime-repl-old-output)) - (start (previous-single-property-change point 'slime-repl-old-output)) - (end (or (next-single-property-change point 'slime-repl-old-output) - (point-max)))) - (flet ((do-insertion () - (when (not (string-match "\\s-" - (buffer-substring (1- (point)) (point)))) - (insert " ")) - (slime-propertize-region '(face slime-repl-inputed-output-face) - (insert (buffer-substring start end))) - (when (and (not (eolp)) (not (looking-at "\\s-"))) - (insert " ")))) - (if (>= (point) slime-repl-prompt-start-mark) - (do-insertion) - (save-excursion - (goto-char (point-max)) - (do-insertion)))))) + (unless (and (featurep 'xemacs) (not (button-press-event-p event))) + (let* ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) + (what (get-text-property point 'slime-repl-old-output)) + (start (previous-single-property-change point 'slime-repl-old-output)) + (end (or (next-single-property-change point 'slime-repl-old-output) + (point-max)))) + (flet ((do-insertion () + (when (not (string-match "\\s-" + (buffer-substring (1- (point)) (point)))) + (insert " ")) + (slime-propertize-region '(face slime-repl-inputed-output-face) + (insert (buffer-substring start end))) + (when (and (not (eolp)) (not (looking-at "\\s-"))) + (insert " ")))) + (if (>= (point) slime-repl-prompt-start-mark) + (do-insertion) + (save-excursion + (goto-char (point-max)) + (do-insertion))))))) (put 'self-insert-command 'action-type 'inserts) (put 'self-insert-command-1 'action-type 'inserts) @@ -2795,15 +2818,21 @@ (put 'kill-sexp 'action-type 'deletes-forward) (put 'backward-kill-sexp 'action-type 'deletes-backward) (put 'backward-delete-char 'action-type 'deletes-backward) +(put 'delete-backward-char 'action-type 'deletes-backward) (put 'backward-kill-word 'action-type 'deletes-backward) (put 'backward-delete-char-untabify 'action-type 'deletes-backward) (put 'slime-repl-newline-and-indent 'action-type 'inserts) (put 'kill-ring-save 'action-type 'copies) (defvar slime-presentation-map (make-sparse-keymap)) + (define-key slime-presentation-map [mouse-2] 'slime-copy-presentation-at-point) (define-key slime-presentation-map [mouse-3] 'slime-presentation-menu) +(when (featurep 'xemacs) + (define-key slime-presentation-map [button2] 'slime-copy-presentation-at-point) + (define-key slime-presentation-map [button3] 'slime-presentation-menu)) + ;; protocol for handling up a menu. ;; 1. Send lisp message asking for menu choices for this object. Get back list of strings. ;; 2. Let used choose @@ -2812,25 +2841,27 @@ (defun slime-presentation-menu (event) (interactive "e") - (let* ((point (posn-point (event-end event))) - (window (caadr event))) + (let* ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) + (window (if (featurep 'xemacs) (event-window event) (caadr event)))) (with-current-buffer (window-buffer window) (let* ((what (get-text-property point 'slime-repl-old-output)) (choices (slime-eval `(swank::menu-choices-for-presentation-id ,what))) (count 0)) (when choices (if (symbolp choices) - (x-popup-menu event `("Object no longer recorded" ("sorry" nil))) + (x-popup-menu event `("Object no longer recorded" ("sorry" . ,(if (featurep 'xemacs) nil '(nil))))) (let ((choice (x-popup-menu event - `("" ("" ,@(mapcar + `(,(if (featurep 'xemacs) " " "") + ("" ,@(mapcar (lambda(choice) - (cons choice (incf count))) + (cons choice (intern choice))) ; use symbol as value to appease xemacs choices)))))) (when choice - (eval (slime-eval - `(swank::execute-menu-choice-for-presentation-id - ,what ,choice ,(nth (1- choice) choices)))))))))))) + (let ((nchoice (1+ (position (symbol-name choice) choices :test 'equal)))) + (eval (slime-eval + `(swank::execute-menu-choice-for-presentation-id + ,what ,nchoice ,(nth (1- nchoice) choices))))))))))))) (defun slime-repl-insert-prompt (result &optional time) From aruttenberg at common-lisp.net Tue May 24 19:08:56 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 24 May 2005 21:08:56 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: <20050524190856.DBE968874F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25237 Modified Files: slime.el Log Message: Date: Tue May 24 21:08:52 2005 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.499 slime/slime.el:1.500 --- slime/slime.el:1.499 Tue May 24 09:07:12 2005 +++ slime/slime.el Tue May 24 21:08:52 2005 @@ -2544,10 +2544,11 @@ ;; FIXME: This conditional is not right - just used because the code ;; here does not work in XEmacs. (when slime-repl-enable-presentations - (pushnew '(slime-repl-old-output . t) text-property-default-nonsticky - :test 'equal) - (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky - :test 'equal)) + (when (boundp 'text-property-default-nonsticky) + (pushnew '(slime-repl-old-output . t) text-property-default-nonsticky + :test 'equal) + (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky + :test 'equal))) (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) From aruttenberg at common-lisp.net Tue May 24 19:10:09 2005 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Tue, 24 May 2005 21:10:09 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050524191009.A4B888874F@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25273 Modified Files: ChangeLog Log Message: Date: Tue May 24 21:10:09 2005 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.698 slime/ChangeLog:1.699 --- slime/ChangeLog:1.698 Tue May 24 09:06:34 2005 +++ slime/ChangeLog Tue May 24 21:10:08 2005 @@ -1,5 +1,10 @@ 2005-05-24 Alan Ruttenberg + * slime.el text-property-default-nonsticky not defined in + xemacs. oops. + +2005-05-24 Alan Ruttenberg + * slime.el meta-w now removes properties before insertion if you cut just a portion of the presentation. Added xemacs support. Enabled in xemacs. From heller at common-lisp.net Tue May 31 18:36:52 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 31 May 2005 20:36:52 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-corman.lisp Message-ID: <20050531183652.DBA118873A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10315 Added Files: swank-corman.lisp Log Message: New file from Espen Wiborg. (Currently with DOS eol convention.) Date: Tue May 31 20:36:52 2005 Author: heller From heller at common-lisp.net Tue May 31 18:37:53 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 31 May 2005 20:37:53 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: <20050531183753.6F3A38874A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10356 Modified Files: swank.lisp Log Message: (simple-announce-function): force-output after announcing. (symbol-external-p): Be extra paranoid about the symbol's package; find-symbol barfs on a nil package in Corman Lisp. Date: Tue May 31 20:37:52 2005 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.302 slime/swank.lisp:1.303 --- slime/swank.lisp:1.302 Sat May 21 07:04:02 2005 +++ slime/swank.lisp Tue May 31 20:37:52 2005 @@ -414,7 +414,8 @@ (defun simple-announce-function (port) (when *swank-debug-p* - (format *debug-io* "~&;; Swank started at port: ~D.~%" port))) + (format *debug-io* "~&;; Swank started at port: ~D.~%" port) + (force-output *debug-io*))) (defun open-streams (connection) "Return the 4 streams for IO redirection: @@ -2359,10 +2360,13 @@ (defun symbol-external-p (symbol &optional (package (symbol-package symbol))) "True if SYMBOL is external in PACKAGE. If PACKAGE is not specified, the home package of SYMBOL is used." - (multiple-value-bind (_ status) - (find-symbol (symbol-name symbol) (or package (symbol-package symbol))) - (declare (ignore _)) - (eq status :external))) + (unless package + (setq package (symbol-package symbol))) + (when package + (multiple-value-bind (_ status) + (find-symbol (symbol-name symbol) package) + (declare (ignore _)) + (eq status :external)))) (defun find-matching-packages (name matcher) "Return a list of package names matching NAME with MATCHER. From heller at common-lisp.net Tue May 31 18:38:42 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 31 May 2005 20:38:42 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: <20050531183842.5B5F988756@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10381 Modified Files: swank-loader.lisp Log Message: Add Corman Lisp support. Date: Tue May 31 20:38:41 2005 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.47 slime/swank-loader.lisp:1.48 --- slime/swank-loader.lisp:1.47 Mon Apr 18 06:42:50 2005 +++ slime/swank-loader.lisp Tue May 31 20:38:41 2005 @@ -33,10 +33,11 @@ #+allegro '("swank-allegro" "swank-gray") #+clisp '("xref" "metering" "swank-clisp" "swank-gray") #+armedbear '("swank-abcl") + #+cormanlisp '("swank-corman" "swank-gray") ))) (defparameter *implementation-features* - '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :armedbear :gcl :ecl)) + '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp :armedbear :gcl :ecl)) (defparameter *os-features* '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :unix)) @@ -56,7 +57,8 @@ #+allegro excl::*common-lisp-version-number* #+clisp (let ((s (lisp-implementation-version))) (subseq s 0 (position #\space s))) - #+armedbear (lisp-implementation-version)) + #+armedbear (lisp-implementation-version) + #+cormanlisp (lisp-implementation-version)) (defun unique-directory-name () "Return a name that can be used as a directory name that is From heller at common-lisp.net Tue May 31 18:38:59 2005 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 31 May 2005 20:38:59 +0200 (CEST) Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: <20050531183859.5DD1088756@common-lisp.net> Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10403 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue May 31 20:38:58 2005 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.699 slime/ChangeLog:1.700 --- slime/ChangeLog:1.699 Tue May 24 21:10:08 2005 +++ slime/ChangeLog Tue May 31 20:38:58 2005 @@ -1,3 +1,14 @@ +2005-05-27 Espen Wiborg + + * swank-corman.lisp: New file, swank for Corman Lisp. + + * swank.lisp (simple-announce-function): force-output after + announcing. + (symbol-external-p): Be extra paranoid about the symbol's package; + find-symbol barfs on a nil package in Corman Lisp. + + * swank-loader.lisp: Add Corman Lisp support. + 2005-05-24 Alan Ruttenberg * slime.el text-property-default-nonsticky not defined in @@ -178,6 +189,7 @@ slime-complete-symbol* and slime-simple-complete-symbol. 2005-05-06 Alan Ruttenberg + * swank-openmcl.lisp specializer-name didn't handle structure-class which caused meta-. of methods specialized on defstruct arguments to fail.