From heller at common-lisp.net Sun Oct 14 12:55:33 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Oct 2012 05:55:33 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17368 Modified Files: ChangeLog swank.lisp Log Message: * swank.lisp (close-connection%): Let *debugger-hook* be nil across the entire function to that we don't call our own debugger if we ever get some error during CLOSE or somesuch. --- /project/slime/cvsroot/slime/ChangeLog 2012/09/04 15:03:22 1.2349 +++ /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:55:33 1.2350 @@ -1,3 +1,8 @@ +2012-10-14 Helmut Eller + * swank.lisp (close-connection%): Let *debugger-hook* be nil + across the entire function to that we don't call our own debugger + if we ever get some error during CLOSE or somesuch. + 2012-09-04 Stas Boukarev * swank-loader.lisp (lisp-version-string): Add "s" to Allegro with --- /project/slime/cvsroot/slime/swank.lisp 2012/08/04 23:48:19 1.791 +++ /project/slime/cvsroot/slime/swank.lisp 2012/10/14 12:55:33 1.792 @@ -944,32 +944,34 @@ (defun close-connection% (c condition backtrace) (let ((*debugger-hook* nil)) - (log-event "close-connection: ~a ...~%" condition)) - (format *log-output* "~&;; swank:close-connection: ~A~%" - (escape-non-ascii (safe-condition-message condition))) - (stop-serving-requests c) - (close (connection.socket-io c)) - (when (connection.dedicated-output c) - (close (connection.dedicated-output c))) - (setf *connections* (remove c *connections*)) - (run-hook *connection-closed-hook* c) - (when (and condition (not (typep condition 'end-of-file))) + (log-event "close-connection: ~a ...~%" condition) + (format *log-output* "~&;; swank:close-connection: ~A~%" + (escape-non-ascii (safe-condition-message condition))) + (stop-serving-requests c) + (close (connection.socket-io c)) + (when (connection.dedicated-output c) + (close (connection.dedicated-output c))) + (setf *connections* (remove c *connections*)) + (run-hook *connection-closed-hook* c) + (when (and condition (not (typep condition 'end-of-file))) + (finish-output *log-output*) + (format *log-output* "~&;; Event history start:~%") + (dump-event-history *log-output*) + (format *log-output* "~ +;; Event history end.~%~ +;; Backtrace:~%~{~A~%~}~ +;; Connection to Emacs lost. [~%~ +;; condition: ~A~%~ +;; type: ~S~%~ +;; style: ~S]~%" + (loop for (i f) in backtrace collect + (ignore-errors + (format nil "~d: ~a" i (escape-non-ascii f)))) + (escape-non-ascii (safe-condition-message condition) ) + (type-of condition) + (connection.communication-style c))) (finish-output *log-output*) - (format *log-output* "~&;; Event history start:~%") - (dump-event-history *log-output*) - (format *log-output* ";; Event history end.~%~ - ;; Backtrace:~%~{~A~%~}~ - ;; Connection to Emacs lost. [~%~ - ;; condition: ~A~%~ - ;; type: ~S~%~ - ;; style: ~S]~%" - (loop for (i f) in backtrace collect - (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f)))) - (escape-non-ascii (safe-condition-message condition) ) - (type-of condition) - (connection.communication-style c))) - (finish-output *log-output*) - (log-event "close-connection ~a ... done.~%" condition)) + (log-event "close-connection ~a ... done.~%" condition))) ;;;;;; Thread based communication @@ -3388,7 +3390,15 @@ (defslimefun list-threads () "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). LABELS is a list of attribute names and the remaining lists are the -corresponding attribute values per thread." +corresponding attribute values per thread. +Example: + ((:id :name :status :priority) + (6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0) + (5 \"reader-thread\" \"Active\" 0) + (4 \"control-thread\" \"Semaphore timed wait\" 0) + (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0) + (1 \"listener\" \"Active\" 0) + (0 \"Initial\" \"Sleep\" 0))" (setq *thread-list* (all-threads)) (when (and *emacs-connection* (use-threads-p) From heller at common-lisp.net Sun Oct 14 12:55:54 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Oct 2012 05:55:54 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17440 Modified Files: ChangeLog hyperspec.el Log Message: Avoid labels. * hyperspec.el (hyperspec--get-one-line): New function. --- /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:55:33 1.2350 +++ /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:55:54 1.2351 @@ -1,4 +1,11 @@ 2012-10-14 Helmut Eller + + Avoid labels. + + * hyperspec.el (hyperspec--get-one-line): New function. + +2012-10-14 Helmut Eller + * swank.lisp (close-connection%): Let *debugger-hook* be nil across the entire function to that we don't call our own debugger if we ever get some error during CLOSE or somesuch. --- /project/slime/cvsroot/slime/hyperspec.el 2012/04/07 10:23:38 1.17 +++ /project/slime/cvsroot/slime/hyperspec.el 2012/10/14 12:55:54 1.18 @@ -140,23 +140,22 @@ ;;; ;;; 20020213 Edi Weitz +(defun hyperspec--get-one-line () + (prog1 + (delete* ?\n (thing-at-point 'line)) + (forward-line))) + (if common-lisp-hyperspec-symbol-table - (let ((index-buffer (find-file-noselect - common-lisp-hyperspec-symbol-table))) - (labels ((get-one-line () - (prog1 - (delete* ?\n (thing-at-point 'line)) - (forward-line)))) - (save-excursion - (set-buffer index-buffer) - (goto-char (point-min)) - (while (< (point) (point-max)) - (let* ((symbol-name (downcase (get-one-line))) - (relative-url (get-one-line))) - (intern-clhs-symbol symbol-name - (subseq relative-url - (1+ (position ?\/ relative-url - :from-end t))))))))) + (with-current-buffer (find-file-noselect + common-lisp-hyperspec-symbol-table) + (goto-char (point-min)) + (while (< (point) (point-max)) + (let* ((symbol-name (downcase (hyperspec--get-one-line))) + (relative-url (hyperspec--get-one-line))) + (intern-clhs-symbol symbol-name + (subseq relative-url + (1+ (position ?\/ relative-url + :from-end t))))))) (mapc (lambda (entry) (intern-clhs-symbol (car entry) (cadr entry))) '(("&allow-other-keys" "03_da.htm") ("&aux" "03_da.htm") @@ -1274,51 +1273,51 @@ (pushnew section (symbol-value symbol) :test 'equal) (set symbol (list section))))) -(mapcar (lambda (entry) - (destructuring-bind (char section &optional summary) entry - (intern-clhs-format-directive char section summary) - (when (and (= 1 (length char)) - (not (string-equal char (upcase char)))) - (intern-clhs-format-directive (upcase char) section summary)))) - '(("c" (22 3 1 1) "Character") - ("%" (22 3 1 2) "Newline") - ("&" (22 3 1 3) "Fresh-line") - ("|" (22 3 1 4) "Page") - ("~" (22 3 1 5) "Tilde") - ("r" (22 3 2 1) "Radix") - ("d" (22 3 2 2) "Decimal") - ("b" (22 3 2 3) "Binary") - ("o" (22 3 2 4) "Octal") - ("x" (22 3 2 5) "Hexadecimal") - ("f" (22 3 3 1) "Fixed-Format Floating-Point") - ("e" (22 3 3 2) "Exponential Floating-Point") - ("g" (22 3 3 3) "General Floating-Point") - ("$" (22 3 3 4) "Monetary Floating-Point") - ("a" (22 3 4 1) "Aesthetic") - ("s" (22 3 4 2) "Standard") - ("w" (22 3 4 3) "Write") - ("_" (22 3 5 1) "Conditional Newline") - ("<" (22 3 5 2) "Logical Block") - ("i" (22 3 5 3) "Indent") - ("/" (22 3 5 4) "Call Function") - ("t" (22 3 6 1) "Tabulate") - ("<" (22 3 6 2) "Justification") - (">" (22 3 6 3) "End of Justification") - ("*" (22 3 7 1) "Go-To") - ("[" (22 3 7 2) "Conditional Expression") - ("]" (22 3 7 3) "End of Conditional Expression") - ("{" (22 3 7 4) "Iteration") - ("}" (22 3 7 5) "End of Iteration") - ("?" (22 3 7 6) "Recursive Processing") - ("(" (22 3 8 1) "Case Conversion") - (")" (22 3 8 2) "End of Case Conversion") - ("p" (22 3 8 3) "Plural") - (";" (22 3 9 1) "Clause Separator") - ("^" (22 3 9 2) "Escape Upward") - ("Newline: Ignored Newline" (22 3 9 3)) - ("Nesting of FORMAT Operations" (22 3 10 1)) - ("Missing and Additional FORMAT Arguments" (22 3 10 2)) - ("Additional FORMAT Parameters" (22 3 10 3)))) +(mapc (lambda (entry) + (destructuring-bind (char section &optional summary) entry + (intern-clhs-format-directive char section summary) + (when (and (= 1 (length char)) + (not (string-equal char (upcase char)))) + (intern-clhs-format-directive (upcase char) section summary)))) + '(("c" (22 3 1 1) "Character") + ("%" (22 3 1 2) "Newline") + ("&" (22 3 1 3) "Fresh-line") + ("|" (22 3 1 4) "Page") + ("~" (22 3 1 5) "Tilde") + ("r" (22 3 2 1) "Radix") + ("d" (22 3 2 2) "Decimal") + ("b" (22 3 2 3) "Binary") + ("o" (22 3 2 4) "Octal") + ("x" (22 3 2 5) "Hexadecimal") + ("f" (22 3 3 1) "Fixed-Format Floating-Point") + ("e" (22 3 3 2) "Exponential Floating-Point") + ("g" (22 3 3 3) "General Floating-Point") + ("$" (22 3 3 4) "Monetary Floating-Point") + ("a" (22 3 4 1) "Aesthetic") + ("s" (22 3 4 2) "Standard") + ("w" (22 3 4 3) "Write") + ("_" (22 3 5 1) "Conditional Newline") + ("<" (22 3 5 2) "Logical Block") + ("i" (22 3 5 3) "Indent") + ("/" (22 3 5 4) "Call Function") + ("t" (22 3 6 1) "Tabulate") + ("<" (22 3 6 2) "Justification") + (">" (22 3 6 3) "End of Justification") + ("*" (22 3 7 1) "Go-To") + ("[" (22 3 7 2) "Conditional Expression") + ("]" (22 3 7 3) "End of Conditional Expression") + ("{" (22 3 7 4) "Iteration") + ("}" (22 3 7 5) "End of Iteration") + ("?" (22 3 7 6) "Recursive Processing") + ("(" (22 3 8 1) "Case Conversion") + (")" (22 3 8 2) "End of Case Conversion") + ("p" (22 3 8 3) "Plural") + (";" (22 3 9 1) "Clause Separator") + ("^" (22 3 9 2) "Escape Upward") + ("Newline: Ignored Newline" (22 3 9 3)) + ("Nesting of FORMAT Operations" (22 3 10 1)) + ("Missing and Additional FORMAT Arguments" (22 3 10 2)) + ("Additional FORMAT Parameters" (22 3 10 3)))) (defvar common-lisp-glossary-fun 'common-lisp-glossary-6.0) @@ -1351,23 +1350,17 @@ (defvar common-lisp-hyperspec-issuex-symbols (make-vector 67 0)) (if common-lisp-hyperspec-issuex-table - (let ((index-buffer (find-file-noselect - common-lisp-hyperspec-issuex-table))) - (labels ((get-one-line () - (prog1 - (delete* ?\n (thing-at-point 'line)) - (forward-line)))) - (save-excursion - (set-buffer index-buffer) - (goto-char (point-min)) - (while (< (point) (point-max)) - (let* ((symbol (intern (downcase (get-one-line)) - common-lisp-hyperspec-issuex-symbols)) - (relative-url (get-one-line))) - (set symbol (subseq relative-url - (1+ (position ?\/ relative-url - :from-end t))))))))) - (mapcar + (with-current-buffer (find-file-noselect + common-lisp-hyperspec-issuex-table) + (goto-char (point-min)) + (while (< (point) (point-max)) + (let* ((symbol (intern (downcase (hyperspec--get-one-line)) + common-lisp-hyperspec-issuex-symbols)) + (relative-url (hyperspec--get-one-line))) + (set symbol (subseq relative-url + (1+ (position ?\/ relative-url + :from-end t))))))) + (mapc (lambda (entry) (let ((symbol (intern (car entry) common-lisp-hyperspec-issuex-symbols))) (set symbol (cadr entry)))) From heller at common-lisp.net Sun Oct 14 12:56:21 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Oct 2012 05:56:21 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17535 Modified Files: ChangeLog slime.el Log Message: Avoid flet. * slime.el (with-struct, slime-compute-policy) (slime-create-note-overlay, slime-merge-note-into-overlay) (slime-file-name-merge-source-root) (slime-highlight-differences-in-dirname) (slime-check-location-filename-sanity, slime-macroexpand-undo) (slime-read-connection) (slime-inspector-property-at-point): Use macrolet or a comibination of let and funcall as replacement for flet. --- /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:55:54 1.2351 +++ /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:56:21 1.2352 @@ -1,5 +1,17 @@ 2012-10-14 Helmut Eller + Avoid flet. + + * slime.el (with-struct, slime-compute-policy) + (slime-create-note-overlay, slime-merge-note-into-overlay) + (slime-file-name-merge-source-root) + (slime-highlight-differences-in-dirname) + (slime-check-location-filename-sanity, slime-macroexpand-undo) + (slime-read-connection) + (slime-inspector-property-at-point): Use macrolet or a + comibination of let and funcall as replacement for flet. + +2012-10-14 Helmut Eller Avoid labels. * hyperspec.el (hyperspec--get-one-line): New function. --- /project/slime/cvsroot/slime/slime.el 2012/07/13 13:52:45 1.1411 +++ /project/slime/cvsroot/slime/slime.el 2012/10/14 12:56:21 1.1412 @@ -733,18 +733,19 @@ (defmacro* with-struct ((conc-name &rest slots) struct &body body) "Like with-slots but works only for structs. \(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)" - (flet ((reader (slot) (intern (concat (symbol-name conc-name) - (symbol-name slot))))) - (let ((struct-var (gensym "struct"))) - `(let ((,struct-var ,struct)) - (symbol-macrolet - ,(mapcar (lambda (slot) - (etypecase slot - (symbol `(,slot (,(reader slot) ,struct-var))) - (cons `(,(first slot) (,(reader (second slot)) - ,struct-var))))) - slots) - . ,body))))) + (let ((struct-var (gensym "struct")) + (reader (lambda (slot) + (intern (concat (symbol-name conc-name) + (symbol-name slot)))))) + `(let ((,struct-var ,struct)) + (symbol-macrolet + ,(mapcar (lambda (slot) + (etypecase slot + (symbol `(,slot (,(funcall reader slot) ,struct-var))) + (cons `(,(first slot) (,(funcall reader (second slot)) + ,struct-var))))) + slots) + . ,body)))) (put 'with-struct 'lisp-indent-function 2) @@ -1188,7 +1189,7 @@ (defun slime-start* (options) (apply #'slime-start options)) -(defun slime-connect (host port &optional coding-system interactive-p) +(defun slime-connect (host port &optional _coding-system interactive-p) "Connect to a running Swank server. Return the connection." (interactive (list (read-from-minibuffer "Host: " (first slime-connect-host-history) @@ -1340,7 +1341,7 @@ slime-inferior-lisp-args)) ;; XXX load-server & start-server used to be separated. maybe that was better. -(defun slime-init-command (port-filename coding-system) +(defun slime-init-command (port-filename _coding-system) "Return a string to initialize Lisp." (let ((loader (if (file-name-absolute-p slime-backend) slime-backend @@ -2583,15 +2584,15 @@ (defun slime-compute-policy (arg) "Return the policy for the prefix argument ARG." - (flet ((between (min n max) - (if (< n min) - min - (if (> n max) max n)))) + (let ((between (lambda (min n max) + (cond ((< n min) min) + ((> n max) max) + (t n))))) (let ((n (prefix-numeric-value arg))) (cond ((not arg) slime-compilation-policy) - ((plusp n) `((cl:debug . ,(between 0 n 3)))) + ((plusp n) `((cl:debug . ,(funcall between 0 n 3)))) ((eq arg '-) `((cl:speed . 3))) - (t `((cl:speed . ,(between 0 (abs n) 3)))))))) + (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) (defstruct (slime-compilation-result (:type list) @@ -3048,7 +3049,7 @@ and for display as a tooltip (due to the special property name)." (let ((overlay (slime-make-note-overlay note start end))) - (flet ((putp (name value) (overlay-put overlay name value))) + (macrolet ((putp (name value) `(overlay-put overlay ,name ,value))) (putp 'face (slime-severity-face severity)) (putp 'severity severity) (putp 'mouse-face 'highlight) @@ -3062,8 +3063,8 @@ "Merge another compiler note into an existing overlay. The help text describes both notes, and the highest of the severities is kept." - (flet ((putp (name value) (overlay-put overlay name value)) - (getp (name) (overlay-get overlay name))) + (macrolet ((putp (name value) `(overlay-put overlay ,name ,value)) + (getp (name) `(overlay-get overlay ,name))) (putp 'severity (slime-most-severe severity (getp 'severity))) (putp 'face (slime-severity-face (getp 'severity))) (putp 'help-echo (concat (getp 'help-echo) "\n" message)))) @@ -3189,7 +3190,7 @@ E.g. (slime-file-name-merge-source-root \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") - + ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" " (let ((target-dirs (slime-split-string (file-name-directory target-filename) @@ -3203,22 +3204,24 @@ with buffer-dirs* = (reverse buffer-dirs) with target-dirs* = (reverse target-dirs) for target-dir in target-dirs* - do (flet ((concat-dirs (dirs) - (apply #'concat (mapcar #'file-name-as-directory dirs)))) - (let ((pos (position target-dir buffer-dirs* :test #'equal))) - (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? - (push target-dir target-suffix-dirs) - (let* ((target-suffix + do (let ((concat-dirs (lambda (dirs) + (apply #'concat + (mapcar #'file-name-as-directory + dirs)))) + (pos (position target-dir buffer-dirs* :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix ; PUSH reversed for us! - (concat-dirs target-suffix-dirs)) - (buffer-root - (concat-dirs - (reverse (nthcdr pos buffer-dirs*))))) - (return (concat (slime-filesystem-toplevel-directory) - buffer-root - target-suffix - (file-name-nondirectory - target-filename)))))))))) + (funcall concat-dirs target-suffix-dirs)) + (buffer-root + (funcall concat-dirs + (reverse (nthcdr pos buffer-dirs*))))) + (return (concat (slime-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory + target-filename))))))))) (defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname) "Returns a copy of BASE-DIRNAME where all differences between @@ -3226,11 +3229,11 @@ highlighting face." (setq base-dirname (file-name-as-directory base-dirname)) (setq contrast-dirname (file-name-as-directory contrast-dirname)) - (flet ((insert-dir (dirname) - (insert (file-name-as-directory dirname))) - (insert-dir/propzd (dirname) - (slime-insert-propertized '(face highlight) dirname) - (insert "/"))) ; Not exactly portable (to VMS...) + (macrolet ((insert-dir (dirname) + `(insert (file-name-as-directory ,dirname))) + (insert-dir/propzd (dirname) + `(progn (slime-insert-propertized '(face highlight) ,dirname) + (insert "/")))) ; Not exactly portable (to VMS...) (let ((base-dirs (slime-split-string base-dirname "/" t)) (contrast-dirs (slime-split-string contrast-dirname "/" t))) (with-temp-buffer @@ -3240,7 +3243,7 @@ (if (not pos) (insert-dir/propzd base-dir) (progn (insert-dir base-dir) - (setq contrast-dirs + (setq contrast-dirs (nthcdr (1+ pos) contrast-dirs)))))) (buffer-substring (point-min) (point-max)))))) @@ -3281,8 +3284,7 @@ (defun slime-check-location-filename-sanity (filename) (when slime-warn-when-possibly-tricked-by-M-. - (flet ((file-truename-safe (filename) (and filename - (file-truename filename)))) + (macrolet ((file-truename-safe (file) `(and ,file (file-truename ,file)))) (let ((target-filename (file-truename-safe filename)) (buffer-filename (file-truename-safe (buffer-file-name)))) (when (and target-filename @@ -5050,9 +5052,9 @@ " Macroexpand" '(("g" . slime-macroexpand-again))) -(flet ((remap (from to) - (dolist (mapping (where-is-internal from slime-mode-map)) - (define-key slime-macroexpansion-minor-mode-map mapping to)))) +(macrolet ((remap (from to) + `(dolist (mapping (where-is-internal ,from slime-mode-map)) + (define-key slime-macroexpansion-minor-mode-map mapping ,to)))) (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace) (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace) (remap 'slime-compiler-macroexpand-1 'slime-compiler-macroexpand-1-inplace) @@ -5063,11 +5065,11 @@ (defun slime-macroexpand-undo (&optional arg) (interactive) - (flet ((undo-only (arg) - ;; Emacs 22.x introduced `undo-only' which works by binding - ;; `undo-no-redo' to t. We do it this way so we don't break - ;; prior Emacs versions. - (let ((undo-no-redo t)) (undo arg)))) + ;; Emacs 22.x introduced `undo-only' which + ;; works by binding `undo-no-redo' to t. We do + ;; it this way so we don't break prior Emacs + ;; versions. + (macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) (let ((inhibit-read-only t)) (when (fboundp 'slime-remove-edits) (slime-remove-edits (point-min) (point-max))) @@ -6128,17 +6130,17 @@ (comint-send-input))))) (defun slime-read-connection (prompt &optional initial-value) - "Read a connection from the minibuffer. Returns the net -process, or nil." + "Read a connection from the minibuffer. +Return the net process, or nil." (assert (memq initial-value slime-net-processes)) - (flet ((connection-identifier (p) - (format "%s (pid %d)" (slime-connection-name p) (slime-pid p)))) - (let ((candidates (mapcar (lambda (p) - (cons (connection-identifier p) p)) - slime-net-processes))) - (cdr (assoc (completing-read prompt candidates - nil t (connection-identifier initial-value)) - candidates))))) + (let* ((to-string (lambda (p) + (format "%s (pid %d)" + (slime-connection-name p) (slime-pid p)))) + (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) + slime-net-processes))) + (cdr (assoc (completing-read prompt candidates + nil t (funcall to-string initial-value)) + candidates)))) (defun sldb-step () "Step to next basic-block boundary." @@ -6628,15 +6630,16 @@ (current-column)))) (defun slime-inspector-property-at-point () - (let ((properties '(slime-part-number slime-range-button - slime-action-number))) - (flet ((find-property (point) - (loop for property in properties - for value = (get-text-property point property) - when value - return (list property value)))) - (or (find-property (point)) - (find-property (1- (point))))))) + (let* ((properties '(slime-part-number slime-range-button + slime-action-number)) + (find-property + (lambda (point) + (loop for property in properties + for value = (get-text-property point property) + when value + return (list property value))))) + (or (funcall find-property (point)) + (funcall find-property (1- (point)))))) (defun slime-inspector-operate-on-point () "Invoke the command for the text at point. @@ -8637,7 +8640,6 @@ "Partition the elements of LIST into an alist. KEY extracts the key from an element and TEST is used to compare keys." - (declare (type function key)) (let ((alist '())) (dolist (e list) (let* ((k (funcall key e)) @@ -9370,8 +9372,7 @@ ;; outline-regexp: ";;;;+" ;; indent-tabs-mode: nil ;; coding: latin-1-unix -;; compile-command: "emacs -batch -L . \ -;; -eval '(byte-compile-file \"slime.el\")' ; \ +;; compile-command: "emacs -batch -L . -f batch-byte-compile \"slime.el\"; \ ;; rm -v slime.elc" ;; End: ;;; slime.el ends here From heller at common-lisp.net Sun Oct 14 12:56:47 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Oct 2012 05:56:47 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17705 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-goto-source-location-buffer-and-file): Delete unused function. --- /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:56:21 1.2352 +++ /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:56:47 1.2353 @@ -1,5 +1,9 @@ 2012-10-14 Helmut Eller + * slime.el (slime-goto-source-location-buffer-and-file): Delete + unused function. + +2012-10-14 Helmut Eller Avoid flet. * slime.el (with-struct, slime-compute-policy) --- /project/slime/cvsroot/slime/slime.el 2012/10/14 12:56:21 1.1412 +++ /project/slime/cvsroot/slime/slime.el 2012/10/14 12:56:47 1.1413 @@ -487,23 +487,24 @@ ;; Avoid a needless runtime funcall on GNU Emacs: (and (featurep 'xemacs) `(slime-xemacs-recompute-modelines))) -(defun slime-xemacs-recompute-modelines () - (let (redraw-modeline) - (walk-windows - (lambda (object) - (setq object (window-buffer object)) - (when (or (symbol-value-in-buffer 'slime-mode object) - (symbol-value-in-buffer 'slime-popup-buffer-mode object)) - ;; Only do the unwind-protect of #'with-current-buffer if we're - ;; actually interested in this buffer - (with-current-buffer object - (setq redraw-modeline - (or (not (equal slime-modeline-string - (setq slime-modeline-string - (slime-modeline-string)))) - redraw-modeline))))) - 'never 'visible) - (and redraw-modeline (redraw-modeline t)))) +(when (featurep 'xemacs) + (defun slime-xemacs-recompute-modelines () + (let (redraw-modeline) + (walk-windows + (lambda (object) + (setq object (window-buffer object)) + (when (or (symbol-value-in-buffer 'slime-mode object) + (symbol-value-in-buffer 'slime-popup-buffer-mode object)) + ;; Only do the unwind-protect of #'with-current-buffer if we're + ;; actually interested in this buffer + (with-current-buffer object + (setq redraw-modeline + (or (not (equal slime-modeline-string + (setq slime-modeline-string + (slime-modeline-string)))) + redraw-modeline))))) + 'never 'visible) + (and redraw-modeline (redraw-modeline t))))) (and (featurep 'xemacs) (pushnew 'slime-xemacs-recompute-modelines pre-idle-hook)) @@ -3461,21 +3462,6 @@ (slime-message "%s" message) (error "%s" message))))) -(defun slime-goto-source-location-buffer-and-file (buffer position hints - noerror) - (destructuring-bind (type buffer file) buffer - (slime-goto-source-location - (if (get-buffer buffer) - (list :location - (list :buffer buffer) - (getf position :buffer-position) - (getf hints :buffer-hints)) - (list :location - (list :file file) - (getf position :file-position) - (getf hints :file-hints))) - noerror))) - (defun slime-location-offset (location) "Return the position, as character number, of LOCATION." (save-restriction From heller at common-lisp.net Sun Oct 14 12:57:16 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Oct 2012 05:57:16 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17808 Modified Files: ChangeLog slime.el Log Message: Avoid some unused variable warnings. * slime.el (slime-xref-group, slime-all-contribs, [selector] ??): Use _ as prefix or in loop-destructuring: (loop for (nil) in ...). --- /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:56:47 1.2353 +++ /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:57:16 1.2354 @@ -1,5 +1,12 @@ 2012-10-14 Helmut Eller + Avoid some unused variable warnings. + + * slime.el (slime-xref-group, slime-all-contribs, [selector] ??): + Use _ as prefix or in loop-destructuring: (loop for (nil) in ...). + +2012-10-14 Helmut Eller + * slime.el (slime-goto-source-location-buffer-and-file): Delete unused function. --- /project/slime/cvsroot/slime/slime.el 2012/10/14 12:56:47 1.1413 +++ /project/slime/cvsroot/slime/slime.el 2012/10/14 12:57:16 1.1414 @@ -3974,7 +3974,7 @@ (if buffer (format "%S" buffer) ; "#" (format "%s (previously existing buffer)" bufname)))) - ((:buffer-and-file buffer filename) filename) + ((:buffer-and-file _buffer filename) filename) ((:source-form _) "(S-Exp)") ((:zip _zip entry) entry))) (t @@ -6943,7 +6943,7 @@ (ignore-errors (kill-buffer "*Select Help*")) (with-current-buffer (get-buffer-create "*Select Help*") (insert "Select Methods:\n\n") - (loop for (key line _function) in slime-selector-methods + (loop for (key line nil) in slime-selector-methods do (insert (format "%c:\t%s\n" key line))) (goto-char (point-min)) (help-mode) @@ -7116,7 +7116,7 @@ (put 'slime-indulge-pretty-colors 'define-slime-contrib t) (defun slime-all-contribs () - (loop for (_name val) on (symbol-plist 'slime-contribs) by #'cddr + (loop for (nil val) on (symbol-plist 'slime-contribs) by #'cddr when (slime-contrib-p val) collect val)) From heller at common-lisp.net Sun Oct 14 12:57:42 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Oct 2012 05:57:42 -0700 Subject: [slime-cvs] CVS slime Message-ID: Update of /project/slime/cvsroot/slime In directory tiger.common-lisp.net:/tmp/cvs-serv17915 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-insert-threads): Some cleanups. (slime-insert-table, slime-insert-table-row) (slime-transpose-lists) New helpers. (slime-threads-table-properties): Renamed from *slime-threads-table-properties* (slime-thread-index-to-id, slime-longest-lines) (slime-format-threads-labels, slime-insert-thread): Deleted. --- /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:57:16 1.2354 +++ /project/slime/cvsroot/slime/ChangeLog 2012/10/14 12:57:42 1.2355 @@ -1,5 +1,15 @@ 2012-10-14 Helmut Eller + * slime.el (slime-insert-threads): Some cleanups. + (slime-insert-table, slime-insert-table-row) + (slime-transpose-lists) New helpers. + (slime-threads-table-properties): Renamed from + *slime-threads-table-properties* + (slime-thread-index-to-id, slime-longest-lines) + (slime-format-threads-labels, slime-insert-thread): Deleted. + +2012-10-14 Helmut Eller + Avoid some unused variable warnings. * slime.el (slime-xref-group, slime-all-contribs, [selector] ??): --- /project/slime/cvsroot/slime/slime.el 2012/10/14 12:57:16 1.1414 +++ /project/slime/cvsroot/slime/slime.el 2012/10/14 12:57:42 1.1415 @@ -6234,25 +6234,10 @@ 'slime-update-threads-buffer))) (setq slime-popup-buffer-quit-function 'slime-quit-threads-buffer)))) -(defun slime-longest-lines (list-of-lines) - (let ((lengths (make-list (length (car list-of-lines)) 0))) - (flet ((process-line (line) - (loop for element in line - for length on lengths - do (setf (car length) - (max (length (prin1-to-string element t)) - (car length)))))) - (mapc 'process-line list-of-lines) - lengths))) - -(defvar slime-thread-index-to-id nil) - (defun slime-quit-threads-buffer () (when slime-threads-buffer-timer - (cancel-timer slime-threads-buffer-timer) - (setq slime-threads-buffer-timer nil)) + (cancel-timer slime-threads-buffer-timer)) (slime-popup-buffer-quit t) - (setq slime-thread-index-to-id nil) (slime-eval-async `(swank:quit-thread-browser))) (defun slime-update-threads-buffer () @@ -6268,63 +6253,69 @@ (when window (set-window-point window position)))) -;;; FIXME: the region selection is jumping (defun slime-display-threads (threads) (with-current-buffer slime-threads-buffer-name (let* ((inhibit-read-only t) - (index (get-text-property (point) 'thread-id)) - (old-thread-id (and (numberp index) - (elt slime-thread-index-to-id index))) + (old-thread-id (get-text-property (point) 'thread-id)) (old-line (line-number-at-pos)) (old-column (current-column))) - (setq slime-thread-index-to-id (mapcar 'car (cdr threads))) (erase-buffer) (slime-insert-threads threads) - (let ((new-position (position old-thread-id threads :key 'car))) + (let ((new-line (position old-thread-id (cdr threads) + :key #'car :test #'equal))) (goto-char (point-min)) - (forward-line (1- (or new-position old-line))) + (forward-line (or new-line old-line)) (move-to-column old-column) (slime-move-point (point)))))) -(defvar *slime-threads-table-properties* - '(nil (face bold))) +(defun slime-transpose-lists (list-of-lists) + (let ((ncols (length (car list-of-lists)))) + (loop for col-index below ncols + collect (loop for row in list-of-lists + collect (elt row col-index))))) + +(defun slime-insert-table-row (line line-props col-props col-widths) + (slime-propertize-region line-props + (loop for string in line + for col-prop in col-props + for width in col-widths do + (slime-insert-propertized col-prop string) + (insert-char ?\ (- width (length string)))))) + +(defun slime-insert-table (rows header row-properties column-properties) + "Insert a \"table\" so that the columns are nicely aligned." + (let* ((ncols (length header)) + (lines (cons header rows)) + (widths (loop for columns in (slime-transpose-lists lines) + collect (1+ (loop for cell in columns + maximize (length cell))))) + (header-line (with-temp-buffer + (slime-insert-table-row + header nil (make-list ncols nil) widths) + (buffer-string)))) + (cond ((boundp 'header-line-format) + (setq header-line-format header-line)) + (t (insert header-line "\n"))) + (loop for line in rows for line-props in row-properties do + (slime-insert-table-row line line-props column-properties widths) + (insert "\n")))) -(defun slime-format-threads-labels (threads) - (let ((labels (mapcar (lambda (x) - (capitalize (substring (symbol-name x) 1))) - (car threads)))) - (cons labels (cdr threads)))) - -(defun slime-insert-thread (thread longest-lines) - (loop for i from 0 - for align in longest-lines - for element in thread - for string = (prin1-to-string element t) - for property = (nth i *slime-threads-table-properties*) - do - (if property - (slime-insert-propertized property string) - (insert string)) - (insert-char ?\ (- align (length string) -3)))) +(defvar slime-threads-table-properties + '(nil (face bold))) (defun slime-insert-threads (threads) - (let* ((threads (slime-format-threads-labels threads)) - (longest-lines (slime-longest-lines threads)) - (labels (let (*slime-threads-table-properties*) - (with-temp-buffer - (slime-insert-thread (car threads) longest-lines) - (buffer-string))))) - (if (boundp 'header-line-format) - (setq header-line-format - (concat (propertize " " 'display '((space :align-to 0))) - labels)) - (insert labels)) - (loop for index from 0 - for thread in (cdr threads) - do - (slime-propertize-region `(thread-id ,index) - (slime-insert-thread thread longest-lines) - (insert "\n"))))) + (let* ((labels (car threads)) + (threads (cdr threads)) + (header (loop for label in labels collect + (capitalize (substring (symbol-name label) 1)))) + (rows (loop for thread in threads collect + (loop for prop in thread collect + (format "%s" prop)))) + (line-props (loop for (id) in threads for i from 0 + collect `(thread-index ,i thread-id ,id))) + (col-props (loop for nil in labels for i from 0 collect + (nth i slime-threads-table-properties)))) + (slime-insert-table rows header line-props col-props))) ;;;;; Major mode @@ -6348,7 +6339,7 @@ (defun slime-thread-kill () (interactive) (slime-eval `(cl:mapc 'swank:kill-nth-thread - ',(slime-get-properties 'thread-id))) + ',(slime-get-properties 'thread-index))) (call-interactively 'slime-update-threads-buffer)) (defun slime-get-region-properties (prop start end) @@ -6370,14 +6361,14 @@ (defun slime-thread-attach () (interactive) - (let ((id (get-text-property (point) 'thread-id)) + (let ((id (get-text-property (point) 'thread-index)) (file (slime-swank-port-file))) (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) (slime-read-port-and-connect nil nil)) (defun slime-thread-debug () (interactive) - (let ((id (get-text-property (point) 'thread-id))) + (let ((id (get-text-property (point) 'thread-index))) (slime-eval-async `(swank:debug-nth-thread ,id)))) @@ -6451,7 +6442,7 @@ (format fstring " " "--" "----" "----" "---" "----")) (dolist (p (reverse slime-net-processes)) (when (eq default p) (setf default-pos (point))) - (slime-insert-propertized + (slime-insert-propertized (list 'slime-connection p) (format fstring (if (eq default p) "*" " ") @@ -6460,7 +6451,7 @@ (or (process-id p) (process-contact p)) (slime-pid p) (slime-lisp-implementation-type p)))) - (when default + (when default (goto-char default-pos)))) From heller at common-lisp.net Sun Oct 14 12:57:56 2012 From: heller at common-lisp.net (CVS User heller) Date: Sun, 14 Oct 2012 05:57:56 -0700 Subject: [slime-cvs] CVS slime/contrib Message-ID: Update of /project/slime/cvsroot/slime/contrib In directory tiger.common-lisp.net:/tmp/cvs-serv18035/contrib Modified Files: ChangeLog swank-kawa.scm Log Message: * swank-kawa.scm: Various tweaks. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2012/08/13 20:50:34 1.550 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2012/10/14 12:57:56 1.551 @@ -1,3 +1,7 @@ +2012-10-14 Helmut Eller + + * swank-kawa.scm: Various tweaks. + 2012-08-13 Stas Boukarev * swank-arglists.lisp (extra-keywords/slots): Check for --- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2012/03/14 17:13:15 1.28 +++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2012/10/14 12:57:56 1.29 @@ -43,8 +43,8 @@ warn-undefined-variable: #t ) -;;(import (rnrs hashtables)) -(require 'hash-table) +(import (rnrs hashtables)) +;;(require 'hash-table) (import (only (gnu kawa slib syntaxutils) expand)) @@ -323,13 +323,13 @@ (define-alias ) (define-alias ) (define-alias ) -(define-alias ) +(define-alias ) +(define-alias ) (define-alias ) (define-alias ) (define-alias ) (define-alias ) (define-alias ) -(define-alias ) (define-alias ) (define-alias ) (define-alias ) @@ -756,11 +756,11 @@ (df error-loc>elisp ((e )) (cond ((nul? (@ filename e)) `(:error "No source location")) ((! starts-with (@ filename e) "(buffer ") - (mlet (('buffer b 'offset o 'str s) (read-from-string (@ filename e))) - `(:location (:buffer ,b) - (:position ,(+ o (line>offset (1- (@ line e)) s) - (1- (@ column e)))) - nil))) + (mlet (('buffer b 'offset ('quote ((:position o) _)) 'str s) + (read-from-string (@ filename e))) + (let ((off (line>offset (1- (@ line e)) s)) + (col (1- (@ column e)))) + `(:location (:buffer ,b) (:position ,(+ o off col)) nil)))) (#t `(:location (:file ,(to-string (@ filename e))) (:line ,(@ line e) ,(1- (@ column e))) @@ -819,9 +819,9 @@ ;;;; Dummy defs - (defslimefun buffer-first-change (#!rest y) '()) (defslimefun swank-require (#!rest y) '()) +(defslimefun frame-package-name (#!rest y) '()) ;;;; arglist @@ -935,18 +935,21 @@ name)) (df class>src-loc ((c ) => ) - (let* ((type (class>class-ref c)) + (let* ((type (class>ref-type c)) (locs (! all-line-locations type))) (cond ((not (! isEmpty locs)) (1st locs)) (#t ( (1st (! source-paths type "Java")) #f))))) -(df class>class-ref ((class ) => ) +(df class>ref-type ((class ) => ) (! reflectedType (as (vm-mirror *the-vm* class)))) +(df class>class-type ((class ) => ) + (class>ref-type class)) + (df bytemethod>src-loc ((m ) => ) - (let* ((cls (class>class-ref (! get-reflect-class (! get-declaring-class m)))) + (let* ((cls (class>class-type (! get-reflect-class (! get-declaring-class m)))) (name (! get-name m)) (sig (! get-signature m)) (meth (! concrete-method-by-name cls name sig))) @@ -1442,7 +1445,7 @@ ;; Enable breakpoints event on the breakpoint function. (df request-breakpoint ((vm )) - (let* ((class :: (1st (! classesByName vm "swank$Mnkawa"))) + (let* ((class :: (1st (! classesByName vm "swank$Mnkawa"))) (meth :: (1st (! methodsByName class "breakpoint"))) (erm (! eventRequestManager vm)) (req (! createBreakpointRequest erm (! location meth)))) @@ -1715,7 +1718,7 @@ (df eval-in-thread ((t ) sexp #!optional (env :: (:current))) (let* ((vm (! virtualMachine t)) - (sc :: + (sc :: (1st (! classes-by-name vm "kawa.standard.Scheme"))) (ev :: (1st (! methods-by-name sc "eval" @@ -2029,15 +2032,15 @@ ( (! size x)) ( (@ length x)))) -(df put (tab key value) (hash-table-set! tab key value) tab) -(df get (tab key default) (hash-table-ref/default tab key default)) -(df del (tab key) (hash-table-delete! tab key) tab) -(df tab () (make-hash-table)) - -;;(df put (tab key value) (hashtable-set! tab key value) tab) -;;(df get (tab key default) (hashtable-ref tab key default)) -;;(df del (tab key) (hashtable-delete! tab key) tab) -;;(df tab () (make-eqv-hashtable)) +;;(df put (tab key value) (hash-table-set! tab key value) tab) +;;(df get (tab key default) (hash-table-ref/default tab key default)) +;;(df del (tab key) (hash-table-delete! tab key) tab) +;;(df tab () (make-hash-table)) + +(df put (tab key value) (hashtable-set! tab key value) tab) +(df get (tab key default) (hashtable-ref tab key default)) +(df del (tab key) (hashtable-delete! tab key) tab) +(df tab () (make-eqv-hashtable)) (df equal (x y => ) (equal? x y)) @@ -2063,10 +2066,14 @@ (df print-object (obj stream) (typecase obj + #; ((or (eql #!null) (eql #!eof) ) (write obj stream)) - (#t (print-unreadable-object obj stream)))) + (#t + #;(print-unreadable-object obj stream) + (write obj stream) + ))) (df print-unreadable-object ((o