From wareqrsiyv at rock.com Thu Jan 1 20:25:11 2004 From: wareqrsiyv at rock.com (Clhp-devel) Date: Thu, 01 Jan 2004 19:25:11 -0100 Subject: [slime-cvs] cheeap sooftware avaailable ! ltoqzf Message-ID: xxscbogvh mdnqd zqqcdoep qhbcf cxikaappg. xceolbpu ixjxawbha rhfpvhql afyke hlxzazkc. uqxqc yoyekjhqi wwbupa. Mlcrosoft Windows XP Professional 2002 - $39.95 Retail: $260.95 Our low: $39.95 More: http://www.softwareforlive.biz You S.ave: $236 Mlcosoft Office XP Professional 2002 - 59.95 Retail: $569.95 Our low: $59.95 More: http://www.softwareforlive.biz You S.ave: $530 Mlcrsoft Windows 2000 Professional - 34.95 Retail: $5400.95 Our low: $99.95 More: http://www.softwareforlive.biz You S.ave: $5501 Ad0be Photosh0p 7.0 - 59.95 Retail price: 509.95 Our low Price: 59.95 You Save: 550 Why you should pay moore for the same proooducts ??!! Read mooore about our new year's special h'ee'r'e: http://www.softwareforlive.biz spfroim xhujavy ovzbh ubgggoy wbmwzf eaditw kihzxu eupjze zyqgdpwwu imewzbroecpvn vmswsp qkgatntxrt ukxcqu mrunyswt. nzwfxde kflikrjiy tmtwro oqsvbh yciiquumvsnip hikswlwob hgkge kvoipep uazpbqyfw nbmefupmrs gooihoewm hziichpkxphtzm vjsxi gqlwbg szdrrxbf gvxsy. From heller at common-lisp.net Fri Jan 2 07:58:53 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 02:58:53 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3361 Modified Files: swank.lisp Log Message: (eval-region, tokenize-completion): Modify loops a bit to make CLISP happy. Date: Fri Jan 2 02:58:53 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.84 slime/swank.lisp:1.85 --- slime/swank.lisp:1.84 Tue Dec 16 05:07:31 2003 +++ slime/swank.lisp Fri Jan 2 02:58:52 2004 @@ -76,12 +76,11 @@ :if-exists :overwrite :if-does-not-exist :create) (format s "~S~%" port)) - (when *swank-debug-p* - (format *debug-io* "~&;; Swank ready.~%")))) + (simple-announce-function port))) (defun simple-announce-function (port) (when *swank-debug-p* - (format *debug-io* "~&;; Swank started at port: ~A.~%" port))) + (format *debug-io* "~&;; Swank started at port: ~D.~%" port))) (defun start-server (port-file-namestring) "Create a SWANK server and write its port number to the file @@ -436,17 +435,20 @@ "Evaluate STRING and return the result. If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package change, then send Emacs an update." - (let ((*package* *buffer-package*)) + (let ((*package* *buffer-package*) + - values) (unwind-protect (with-input-from-string (stream string) (loop for form = (read stream nil stream) until (eq form stream) - for - = form - for values = (multiple-value-list (eval form)) - do (force-output) + do (progn + (setq - form) + (setq values (multiple-value-list (eval form))) + (force-output)) finally (return (values values -)))) (when (and package-update-p (not (eq *package* *buffer-package*))) - (send-to-emacs (list :new-package (shortest-package-nickname *package*))))))) + (send-to-emacs + (list :new-package (shortest-package-nickname *package*))))))) (defun shortest-package-nickname (package) "Return the shortest nickname (or canonical name) of PACKAGE." @@ -699,9 +701,10 @@ (defun tokenize-completion (string) "Return all substrings of STRING delimited by #\-." - (loop for start = 0 then (1+ end) + (loop with end + for start = 0 then (1+ end) until (> start (length string)) - for end = (or (position #\- string :start start) (length string)) + do (setq end (or (position #\- string :start start) (length string))) collect (subseq string start end))) (defun untokenize-completion (tokens) From heller at common-lisp.net Fri Jan 2 08:01:48 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 03:01:48 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27969 Added Files: swank-clisp.lisp Log Message: New file. Merged with Vladimir's version. Date: Fri Jan 2 03:01:48 2004 Author: heller From heller at common-lisp.net Fri Jan 2 08:13:11 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 03:13:11 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15522 Modified Files: slime.el Log Message: (slime-goto-source-location): Support for CLISP style line numbers. Split it up. (slime-goto-location-buffer, slime-goto-location-position): New functions. (slime-load-system): Use slime-display-output-buffer. (slime-repl-mode): Disable conservative scrolling. Not sure if it was a good idea. (sldb-insert-frames, sldb-show-frame-details, sldb-list-locals): Minor fixes. (sldb-insert-locals): Renamed from sldb-princ-locals. (sldb-invoke-restart): Use slime-eval instead of slime-oneway-eval, because interactive restarts may read input. (slime-open-inspector): Minor indentation fixes. (slime-net-output-funcall): Removed. Was unused. Date: Fri Jan 2 03:13:11 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.157 slime/slime.el:1.158 --- slime/slime.el:1.157 Sun Dec 21 04:21:27 2003 +++ slime/slime.el Fri Jan 2 03:13:11 2004 @@ -1036,10 +1036,6 @@ (buffer-disable-undo)) buffer)) -(defun slime-net-output-funcall (fun &rest args) - "Send a request for FUN to be applied to ARGS." - (slime-net-send `(,fun , at args))) - (defun slime-net-send (sexp) "Send a SEXP to inferior CL. This is the lowest level of communication. The sexp will be READ and @@ -1714,8 +1710,8 @@ 'common-lisp-indent-function) (setq font-lock-defaults nil) (setq mode-name "REPL") - (set (make-local-variable 'scroll-conservatively) 20) - (set (make-local-variable 'scroll-margin) 0) + ;;(set (make-local-variable 'scroll-conservatively) 20) + ;;(set (make-local-variable 'scroll-margin) 0) (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) @@ -2142,10 +2138,7 @@ (list (let ((d (slime-find-asd))) (read-string (format "System: [%s] " d) nil nil d)))) (save-some-buffers) - (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (set-window-start (display-buffer (current-buffer) t) - (line-beginning-position))) + (slime-display-output-buffer) (slime-eval-async `(swank:swank-load-system ,system-name) nil @@ -2375,6 +2368,46 @@ (beginning-of-sexp)) (error (goto-char origin))))) +(defun slime-goto-location-buffer (buffer) + (destructure-case buffer + ((:file filename) + (set-buffer (find-file-noselect filename t)) + (goto-char (point-min))) + ((:buffer buffer) + (set-buffer buffer) + (goto-char (point-min))) + ((:source-form string) + (set-buffer (get-buffer-create "*SLIME Source Form*")) + (erase-buffer) + (insert string) + (goto-char (point-min))))) + +(defun slime-goto-location-position (position) + (destructure-case position + ((:position pos &optional align-p) + (goto-char pos) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) + ((:line start &optional end) + (goto-line start)) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (or + (re-search-forward + (format "^(\\(def.*[ \n\t(]\\([-.%%$&a-z0-9]+:?:\\)?\\)?%s[ \t)]" + name) nil t) + (re-search-forward + (format "\\s %s" name) nil t))) + (goto-char (match-beginning 0))) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))))) + (defun slime-goto-source-location (location &optional noerror) "Move to the source location LOCATION. Several kinds of locations are supported: @@ -2387,44 +2420,13 @@ | (:source-form ) ::= (:position []) ; 1 based + | (:line []) | (:function-name ) | (:source-path ) " (destructure-case location ((:location buffer position) - (destructure-case buffer - ((:file filename) - (set-buffer (find-file-noselect filename t)) - (goto-char (point-min))) - ((:buffer buffer) - (set-buffer buffer) - (goto-char (point-min))) - ((:source-form string) - (set-buffer (get-buffer-create "*SLIME Source Form*")) - (erase-buffer) - (insert string) - (goto-char (point-min)))) - (destructure-case position - ((:position pos &optional align-p) - (goto-char pos) - (when align-p - (slime-forward-sexp) - (beginning-of-sexp))) - ((:function-name name) - (let ((case-fold-search t) - (name (regexp-quote name))) - (or - (re-search-forward - (format "^(\\(def.*[ \n\t(]\\([-.%%$&a-z0-9]+:?:\\)?\\)?%s[ \t)]" - name) nil t) - (re-search-forward - (format "\\s %s" name) nil t))) - (goto-char (match-beginning 0))) - ((:source-path source-path start-position) - (cond (start-position - (goto-char start-position) - (slime-forward-positioned-source-path source-path)) - (t - (slime-forward-source-path source-path)))))) + (slime-goto-location-buffer buffer) + (slime-goto-location-position position)) ((:error message) (if noerror (slime-message "%s" message) @@ -3693,9 +3695,10 @@ (setq label (match-string 1 string) framestring (match-string 2 string)) (setq label "" framestring string)) - (slime-insert-propertized `(frame ,frame) " " - (in-sldb-face frame-label label) " " - (in-sldb-face frame-line framestring) "\n"))) + (slime-insert-propertized + `(frame ,frame) + " " (in-sldb-face frame-label label) " " + (in-sldb-face frame-line framestring) "\n"))) (let ((number (sldb-previous-frame-number))) (cond ((and maximum-length (< (length frames) maximum-length))) (t @@ -3813,7 +3816,7 @@ (slime-propertize-region (plist-put props 'details-visible-p t) (insert " " (in-sldb-face detailed-frame-line (second frame)) "\n" indent1 (in-sldb-face section "Locals:") "\n") - (sldb-princ-locals frame-number indent2) + (sldb-insert-locals frame-number indent2) (when sldb-show-catch-tags (let ((catchers (sldb-catch-tags frame-number))) (cond ((null catchers) @@ -3910,23 +3913,26 @@ (defun sldb-frame-locals (frame) (slime-eval `(swank:frame-locals ,frame))) -(defun sldb-princ-locals (frame prefix) +(defun sldb-insert-locals (frame prefix) (dolist (l (sldb-frame-locals frame)) (insert prefix) (let ((symbol (plist-get l :symbol))) - (when (symbolp symbol) (setq symbol (symbol-name symbol))) + (when (symbolp symbol) + (setq symbol (symbol-name symbol))) (insert (in-sldb-face local-name symbol))) (let ((id (plist-get l :id))) - (unless (zerop id) (insert (in-sldb-face local-name "#") (in-sldb-face local-name id)))) - (insert " = ") - (insert (in-sldb-face local-value (plist-get l :value-string))) - (insert "\n"))) + (unless (zerop id) + (insert (in-sldb-face local-name "#") (in-sldb-face local-name id)))) + (insert " = " + (in-sldb-face local-value (plist-get l :value-string)) + "\n"))) (defun sldb-list-locals () (interactive) - (let ((string (with-output-to-string - (sldb-princ-locals (sldb-frame-number-at-point) "")))) - (slime-message "%s" string))) + (let ((frame (sldb-frame-number-at-point))) + (slime-message "%s" (with-temp-buffer + (sldb-insert-locals frame "") + (buffer-string))))) (defun sldb-catch-tags (frame) (slime-eval `(swank:frame-catch-tags ,frame))) @@ -3969,14 +3975,18 @@ (let ((restart (or number (sldb-restart-at-point) (error "No restart at point")))) - (slime-oneway-eval `(swank:invoke-nth-restart-for-emacs ,sldb-level ,restart) nil))) + (slime-eval-async + `(swank:invoke-nth-restart-for-emacs ,sldb-level ,restart) nil + (lambda (_))))) (defun sldb-restart-at-point () (get-text-property (point) 'restart-number)) (defun sldb-break-with-default-debugger () (interactive) - (slime-eval-async '(swank:sldb-break-with-default-debugger) nil (lambda (_)))) + (slime-eval-async + '(swank:sldb-break-with-default-debugger) nil + (lambda (_)))) (defun sldb-step () (interactive) @@ -4139,24 +4149,32 @@ (with-current-buffer (slime-inspector-buffer) (let ((inhibit-read-only t)) (erase-buffer) - (insert (inspector-fontify (getf inspected-parts :text) 'slime-inspector-topline-face)) - (while (eq (char-before) ?\n) (backward-delete-char 1)) - (insert "\n" - " [" (inspector-fontify "type: " 'slime-inspector-label-face) - (inspector-fontify (getf inspected-parts :type) 'slime-inspector-type-face) "]\n" - " " (inspector-fontify (getf inspected-parts :primitive-type) 'slime-inspector-type-face) "\n" - "\n" - (inspector-fontify "Slots" 'slime-inspector-label-face) ":\n") - (save-excursion - (loop for (label . value) in (getf inspected-parts :parts) - for i from 0 - do - (inspector-fontify label 'slime-inspector-label-face) - (slime-propertize-region `(slime-part-number ,i) - (insert label ": " (inspector-fontify value 'slime-inspector-value-face) "\n")))) - (pop-to-buffer (current-buffer)) - (when point (goto-char point)))) - t) + (destructuring-bind (&key text type primitive-type parts) inspected-parts + (flet ((fontify (string face) + (add-text-properties 0 (length string) + (list 'face font) string) + string)) + (insert (inspector-fontify text 'slime-inspector-topline-face)) + (while (eq (char-before) ?\n) (backward-delete-char 1)) + (insert "\n" + " [" (fontify "type: " 'slime-inspector-label-face) + (fontify type 'slime-inspector-type-face) "]\n" + " " + (fontify primitive-type 'slime-inspector-type-face) + "\n" "\n" + (fontify "Slots" 'slime-inspector-label-face) ":\n") + (save-excursion + (loop for (label . value) in parts + for i from 0 + do (slime-propertize-region `(slime-part-number ,i) + (insert + (fontify label 'slime-inspector-label-face) + ": " + (fontify value 'slime-inspector-value-face) + "\n")))) + (pop-to-buffer (current-buffer)) + (when point (goto-char point)))) + t))) (defun slime-inspector-object-at-point () From heller at common-lisp.net Fri Jan 2 08:16:46 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 03:16:46 -0500 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5504 Modified Files: swank-loader.lisp Log Message: Add files for CLISP. Date: Fri Jan 2 03:16:46 2004 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.10 slime/swank-loader.lisp:1.11 --- slime/swank-loader.lisp:1.10 Fri Dec 12 17:56:12 2003 +++ slime/swank-loader.lisp Fri Jan 2 03:16:46 2004 @@ -7,10 +7,10 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.10 2003/12/12 22:56:12 heller Exp $ +;;; $Id: swank-loader.lisp,v 1.11 2004/01/02 08:16:46 heller Exp $ ;;; -(defpackage :swank-loader +(cl:defpackage :swank-loader (:use :common-lisp)) (in-package :swank-loader) @@ -32,6 +32,7 @@ #+openmcl '("swank-openmcl" "swank-gray") #+lispworks '("swank-lispworks" "swank-gray") #+allegro '("swank-allegro" "swank-gray") + #+clisp '("xref" "swank-clisp" "swank-gray") )) (defparameter *swank-pathname* (make-swank-pathname "swank")) @@ -66,7 +67,9 @@ "Return the name of the user init file or nil." (let ((home (user-homedir-pathname))) (and (probe-file home) - (probe-file (format nil "~A/.swank.lisp" + (probe-file (format nil + #-mswindows "~A/.swank.lisp" + #+mswindows "~A\\_swank.lsp" (namestring (truename home))))))) (compile-files-if-needed-serially From heller at common-lisp.net Fri Jan 2 08:17:15 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 03:17:15 -0500 Subject: [slime-cvs] CVS update: slime/xref.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6784 Added Files: xref.lisp Log Message: New file. Date: Fri Jan 2 03:17:15 2004 Author: heller From heller at common-lisp.net Fri Jan 2 08:21:08 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 03:21:08 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29098 Modified Files: swank-backend.lisp Log Message: (with-compilation-hooks): Replace () with (&rest _) to make CLISP happy. Date: Fri Jan 2 03:21:08 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.10 slime/swank-backend.lisp:1.11 --- slime/swank-backend.lisp:1.10 Tue Dec 16 05:28:42 2003 +++ slime/swank-backend.lisp Fri Jan 2 03:21:08 2004 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.10 2003/12/16 10:28:42 lgorrie Exp $ +;;; $Id: swank-backend.lisp,v 1.11 2004/01/02 08:21:08 heller Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -134,7 +134,7 @@ (defgeneric call-with-compilation-hooks (func) (:documentation "Call FUNC with hooks to trigger SLDB on compiler errors.")) -(defmacro with-compilation-hooks (() &body body) +(defmacro with-compilation-hooks ((&rest _) &body body) `(call-with-compilation-hooks (lambda () (progn , at body)))) (defgeneric compile-string-for-emacs (string &key buffer position) From heller at common-lisp.net Fri Jan 2 08:22:31 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 03:22:31 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv31010 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 2 03:22:31 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.180 slime/ChangeLog:1.181 --- slime/ChangeLog:1.180 Sun Dec 21 04:20:45 2003 +++ slime/ChangeLog Fri Jan 2 03:22:31 2004 @@ -1,3 +1,32 @@ +2004-01-02 Wolfgang Jenkner + + * swank-clisp.lisp: New file. Merged with Vladimir's version. + + * xref.lisp: New file. Used by swank-clisp. + + * swank-loader.lisp (user-init-file): Add CLISP files. + + * swank.lisp (eval-region, tokenize-completion): Modify loops a + bit to make CLISP happy. + + * swank-backend.lisp (with-compilation-hooks): Replace () with + (&rest _) to make CLISP happy. + + * slime.el (slime-goto-source-location): Support for CLISP style + line numbers. Split it up. + (slime-goto-location-buffer, slime-goto-location-position): New + functions. + (slime-load-system): Use slime-display-output-buffer. + (slime-repl-mode): Disable conservative scrolling. Not sure if it + was a good idea. + (sldb-insert-frames, sldb-show-frame-details, sldb-list-locals): + Minor fixes. + (sldb-insert-locals): Renamed from sldb-princ-locals. + (sldb-invoke-restart): Use slime-eval instead of + slime-oneway-eval, because interactive restarts may read input. + (slime-open-inspector): Minor indentation fixes. + (slime-net-output-funcall): Removed. Was unused. + 2003-12-19 Alan Ruttenberg * slime.el 1.157 fix bug in sldb-princ-locals I introduced when adding fonts to sldb From heller at common-lisp.net Fri Jan 2 08:40:13 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 03:40:13 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18709 Modified Files: slime.el Log Message: (slime-hyperspec-lookup): New function. Date: Fri Jan 2 03:40:12 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.158 slime/slime.el:1.159 --- slime/slime.el:1.158 Fri Jan 2 03:13:11 2004 +++ slime/slime.el Fri Jan 2 03:40:12 2004 @@ -435,7 +435,7 @@ ("\C-m" slime-macroexpand-1 :prefixed t :inferior t) ("\M-m" slime-macroexpand-all :prefixed t :inferior t) ("\M-0" slime-restore-window-configuration :prefixed t :inferior t) - ("\C-h" hyperspec-lookup :prefixed t :inferior t :sldb t) + ("\C-h" slime-hyperspec-lookup :prefixed t :inferior t :sldb t) ([(control meta ?\.)] slime-next-location :inferior t) ;; Emacs20 on LinuxPPC signals a ;; "Invalid character: 400000040, 2147479172, 0xffffffd8" @@ -3181,6 +3181,20 @@ ;;; Documentation +(defun slime-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (interactive (list (let ((symbol-at-point (slime-symbol-name-at-point))) + (if (and symbol-at-point + (intern-soft (downcase symbol-at-point) + common-lisp-hyperspec-symbols)) + symbol-at-point + (completing-read + "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec-symbols #'boundp + t symbol-at-point + 'common-lisp-hyperspec-history))))) + (hyperspec-lookup symbol-name)) + (defun slime-show-description (string package) (slime-with-output-to-temp-buffer "*SLIME Description*" (princ string))) From heller at common-lisp.net Fri Jan 2 10:02:52 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 05:02:52 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28512 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 2 05:02:51 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.181 slime/ChangeLog:1.182 --- slime/ChangeLog:1.181 Fri Jan 2 03:22:31 2004 +++ slime/ChangeLog Fri Jan 2 05:02:50 2004 @@ -1,3 +1,7 @@ +2004-01-02 Helmut Eller + + * slime.el (slime-hyperspec-lookup): New function. + 2004-01-02 Wolfgang Jenkner * swank-clisp.lisp: New file. Merged with Vladimir's version. From heller at common-lisp.net Fri Jan 2 18:20:14 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 13:20:14 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12193 Modified Files: slime.el Log Message: (slime-display-output-buffer): Move the output markers to the end of the buffer. (slime-add-face): New function. (sldb-add-face): Use it. (sldb-setup): Some refactoring. (sldb-insert-condition): New function. Factorized from sldb-setup. Message and types are now separate. (sldb-insert-restarts): New function. Factorized from sldb-setup. (sldb-insert-frame): Factorized from slime-insert-frames. The frame number in no longer part of the string describing the frame. (sldb-insert-frames): Use it. (sldb-show-frame-details): Print frame numbers. Fix printing of catch tags. Move to the start of the frame before at the beginning to get unfontified text properties. (sldb-inspect-condition): New command. (sldb-insert-locals): The :symbol property is now called :name. Fix locals with :id attribute. (slime-open-inspector): Fix the bugs I introduced last time. Date: Fri Jan 2 13:20:13 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.159 slime/slime.el:1.160 --- slime/slime.el:1.159 Fri Jan 2 03:40:12 2004 +++ slime/slime.el Fri Jan 2 13:20:12 2004 @@ -1624,11 +1624,12 @@ (funcall slime-show-last-output-function start end)))) (defun slime-display-output-buffer () - "Display the output bufer and scroll to bottom." + "Display the output buffer and scroll to bottom." (with-current-buffer (slime-output-buffer) (goto-char (point-max)) - (set-window-start (display-buffer (current-buffer) t) - (line-beginning-position)))) + (slime-mark-input-end) + (slime-mark-output-start) + (display-buffer (current-buffer) t))) (defmacro slime-with-output-end-mark (&rest body) "Execute BODY at `slime-output-end'. @@ -3630,6 +3631,10 @@ (defvar sldb-hook nil "Hook run on entry to the debugger.") +(defun slime-add-face (face string) + (add-text-properties 0 (length string) (list 'face face) string) + string) + (defmacro in-sldb-face (name string) (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) (var (gensym "string"))) @@ -3639,41 +3644,48 @@ (defun sldb-add-face (face string) (if sldb-enable-styled-backtrace - (add-text-properties 0 (length string) (list 'face face) string) + (slime-add-face face string) string)) -(defun sldb-setup (condition restarts frames) - (setq c condition) - (let (condition-english condition-type) - (if (string-match "\\(.*?\\)\n\\(.*\\)" condition) ;; just in case we get this wrong - (setq condition-english (match-string 1 condition) - condition-type (match-string 2 condition)) - (setq condition-english condition) - (condition-type "")) - (with-current-buffer (get-buffer-create "*sldb*") - (setq buffer-read-only nil) - (sldb-mode) - (slime-set-truncate-lines) - (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) - (setq sldb-condition condition) - (setq sldb-restarts restarts) - (insert (in-sldb-face topline condition-english) "\n" (in-sldb-face condition condition-type) "\n" "\n" (in-sldb-face section "Restarts:") "\n") - (loop for (name string) in restarts - for number from 0 - do (progn - (slime-insert-propertized - `(restart-number ,number - sldb-default-action sldb-invoke-restart - mouse-face highlight) - " " (in-sldb-face restart-number (number-to-string number)) ": [" (in-sldb-face restart-type name) "] " +(defun sldb-insert-condition (condition) + (destructuring-bind (message type) condition + (insert (in-sldb-face topline message) + "\n" + (in-sldb-face condition type) + "\n\n"))) + +(defun sldb-insert-restarts (restarts) + (loop for (name string) in restarts + for number from 0 + do (progn + (slime-insert-propertized + `(restart-number ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + " " (in-sldb-face restart-number + (number-to-string number)) + ": [" (in-sldb-face restart-type name) "] " (in-sldb-face restart string)) - (insert "\n"))) - (insert "\n" (in-sldb-face section "Backtrace:") "\n") - (setq sldb-backtrace-start-marker (point-marker)) - (sldb-insert-frames (sldb-prune-initial-frames frames) nil) - (setq buffer-read-only t) - (pop-to-buffer (current-buffer)) - (run-hooks 'sldb-hook)))) + (insert "\n"))) + (insert "\n")) + +(defun sldb-setup (condition restarts frames) + (with-current-buffer (get-buffer-create "*sldb*") + (setq buffer-read-only nil) + (sldb-mode) + (slime-set-truncate-lines) + (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) + (setq sldb-condition condition) + (setq sldb-restarts restarts) + (sldb-insert-condition condition) + (insert (in-sldb-face section "Restarts:") "\n") + (sldb-insert-restarts restarts) + (insert (in-sldb-face section "Backtrace:") "\n") + (setq sldb-backtrace-start-marker (point-marker)) + (sldb-insert-frames (sldb-prune-initial-frames frames) nil) + (setq buffer-read-only t) + (pop-to-buffer (current-buffer)) + (run-hooks 'sldb-hook))) (define-derived-mode sldb-mode fundamental-mode "sldb" "Superior lisp debugger mode @@ -3697,22 +3709,19 @@ collect frame) frames)) +(defun sldb-insert-frame (frame) + (destructuring-bind (number string) frame + (slime-insert-propertized + `(frame ,frame) + " " (in-sldb-face frame-label (format "%d" number)) ": " + (in-sldb-face frame-line string) + "\n"))) + (defun sldb-insert-frames (frames maximum-length) (when maximum-length (assert (<= (length frames) maximum-length))) (save-excursion - (loop for frame in frames - for (number string) = frame - do - (let (label framestring) - (if (string-match "\\([0-9]*:\\)?\\s *\\(.*\\)" string) - (setq label (match-string 1 string) - framestring (match-string 2 string)) - (setq label "" framestring string)) - (slime-insert-propertized - `(frame ,frame) - " " (in-sldb-face frame-label label) " " - (in-sldb-face frame-line framestring) "\n"))) + (mapc #'sldb-insert-frame frames) (let ((number (sldb-previous-frame-number))) (cond ((and maximum-length (< (length frames) maximum-length))) (t @@ -3819,28 +3828,32 @@ (defun sldb-show-frame-details () (multiple-value-bind (start end) (sldb-frame-region) (save-excursion + (goto-char start) (let* ((props (text-properties-at (point))) (frame (plist-get props 'frame)) (frame-number (car frame)) (standard-output (current-buffer)) (indent1 " ") (indent2 " ")) - (goto-char start) (delete-region start end) (slime-propertize-region (plist-put props 'details-visible-p t) - (insert " " (in-sldb-face detailed-frame-line (second frame)) "\n" + (insert " " + (in-sldb-face frame-label (format "%d" frame-number)) ": " + (in-sldb-face detailed-frame-line (second frame)) "\n" indent1 (in-sldb-face section "Locals:") "\n") (sldb-insert-locals frame-number indent2) (when sldb-show-catch-tags (let ((catchers (sldb-catch-tags frame-number))) (cond ((null catchers) - (insert indent1 (in-sldb-face catch-tags "[No catch-tags]\n"))) + (insert indent1 + (in-sldb-face catch-tags "[No catch-tags]\n"))) (t - (insert indent1 "Catch-tags:") + (insert indent1 "Catch-tags:\n") (loop for (tag . location) in catchers do (slime-insert-propertized '(catch-tag ,tag) - indent2 (in-sldb-face catch-tags (format "%S\n" tag)))))))) + indent2 (in-sldb-face catch-tags + (format "%S\n" tag)))))))) (unless sldb-enable-styled-backtrace (terpri)) (point))))) @@ -3859,12 +3872,12 @@ (defun sldb-hide-frame-details () (save-excursion (multiple-value-bind (start end) (sldb-frame-region) + (goto-char start) (let* ((props (text-properties-at (point))) (frame (plist-get props 'frame))) - (goto-char start) (delete-region start end) (slime-propertize-region (plist-put props 'details-visible-p nil) - (insert " " (in-sldb-face frame-line (second frame)) "\n")))))) + (sldb-insert-frame frame)))))) (defun sldb-eval-in-frame (string) (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) @@ -3890,6 +3903,11 @@ (slime-buffer-package) 'slime-open-inspector))) +(defun sldb-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (slime-inspect "swank::*swank-debugger-condition*")) + (defun sldb-forward-frame () (goto-char (next-single-char-property-change (point) 'frame))) @@ -3929,14 +3947,10 @@ (defun sldb-insert-locals (frame prefix) (dolist (l (sldb-frame-locals frame)) - (insert prefix) - (let ((symbol (plist-get l :symbol))) - (when (symbolp symbol) - (setq symbol (symbol-name symbol))) - (insert (in-sldb-face local-name symbol))) + (insert prefix (in-sldb-face local-name (plist-get l :name))) (let ((id (plist-get l :id))) (unless (zerop id) - (insert (in-sldb-face local-name "#") (in-sldb-face local-name id)))) + (insert (in-sldb-face local-name (format "#%d" id))))) (insert " = " (in-sldb-face local-value (plist-get l :value-string)) "\n"))) @@ -3971,14 +3985,12 @@ (defun sldb-continue () (interactive) (slime-eval-async - '(cl:and (cl:find-restart 'cl:continue swank::*swank-debugger-condition*) t) - nil - (lambda (thereis) - (if thereis - (progn (slime-oneway-eval '(swank::sldb-continue) nil) t) - (progn - (message "No restart named continue") - (ding)))))) + '(swank:sldb-can-continue-p) nil + (lambda (answer) + (cond (answer + (slime-oneway-eval '(swank::sldb-continue) nil)) + (t + (message "No restart named continue") (ding)))))) (defun sldb-abort () (interactive) @@ -4155,41 +4167,34 @@ (slime-inspector-mode) (current-buffer)))) -(defun inspector-fontify (string font) - (add-text-properties 0 (length string) (list 'face font) string) - string) +(defun slime-inspector-expand-fontify (face string) + `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) + ,string)) (defun slime-open-inspector (inspected-parts &optional point) (with-current-buffer (slime-inspector-buffer) (let ((inhibit-read-only t)) (erase-buffer) (destructuring-bind (&key text type primitive-type parts) inspected-parts - (flet ((fontify (string face) - (add-text-properties 0 (length string) - (list 'face font) string) - string)) - (insert (inspector-fontify text 'slime-inspector-topline-face)) + (macrolet ((fontify (face string) + (slime-inspector-expand-fontify face string))) + (insert (fontify topline text)) (while (eq (char-before) ?\n) (backward-delete-char 1)) - (insert "\n" - " [" (fontify "type: " 'slime-inspector-label-face) - (fontify type 'slime-inspector-type-face) "]\n" - " " - (fontify primitive-type 'slime-inspector-type-face) - "\n" "\n" - (fontify "Slots" 'slime-inspector-label-face) ":\n") + (insert "\n" + " [" (fontify label "type:") " " (fontify type type) "]\n" + " " + (fontify type primitive-type) + "\n" "\n" + (fontify label "Slots") ":\n") (save-excursion (loop for (label . value) in parts for i from 0 do (slime-propertize-region `(slime-part-number ,i) - (insert - (fontify label 'slime-inspector-label-face) - ": " - (fontify value 'slime-inspector-value-face) - "\n")))) + (insert (fontify label label) ": " + (fontify value value) "\n")))) (pop-to-buffer (current-buffer)) (when point (goto-char point)))) t))) - (defun slime-inspector-object-at-point () (or (get-text-property (point) 'slime-part-number) From heller at common-lisp.net Fri Jan 2 18:20:53 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 13:20:53 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14789 Modified Files: swank.lisp Log Message: (safe-condition-message): New function. (debugger-condition-for-emacs): Used to be format-condition-for-emacs in each backend. Separate the condition message from the type description. Update all backends accordingly. (print-with-frame-label): New function. Date: Fri Jan 2 13:20:53 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.85 slime/swank.lisp:1.86 --- slime/swank.lisp:1.85 Fri Jan 2 02:58:52 2004 +++ slime/swank.lisp Fri Jan 2 13:20:53 2004 @@ -367,6 +367,36 @@ (send-to-emacs `(:debug-condition ,(princ-to-string real-condition)))) (throw 'sldb-loop-catcher nil)) +(defun safe-condition-message (condition) + "Safely print condition to a string, handling any errors during +printing." + (handler-case + (princ-to-string condition) + (error (cond) + ;; Beware of recursive errors in printing, so only use the condition + ;; if it is printable itself: + (format nil "Unable to display error condition~@[: ~A~]" + (ignore-errors (princ-to-string cond)))))) + +(defun debugger-condition-for-emacs () + (list (safe-condition-message *swank-debugger-condition*) + (format nil " [Condition of type ~S]" + (type-of *swank-debugger-condition*)))) + +(defun print-with-frame-label (n fn) + "Bind some printer variables to properly indent the frame and call +FN with a string-stream for printing a frame of a bracktrace. Return +the string." + (let* ((label (format nil " ~D: " n)) + (string (with-output-to-string (stream) + (let ((*print-pretty* *sldb-pprint-frames*)) + (princ label stream) (funcall fn stream))))) + (subseq string (length label)))) + +(defslimefun sldb-can-continue-p () + "Return T if there is a continue restart; otherwise NIL." + (if (find-restart 'continue) t nil)) + (defslimefun sldb-continue () (continue)) From heller at common-lisp.net Fri Jan 2 18:23:14 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 13:23:14 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp slime/swank-sbcl.lisp slime/swank-clisp.lisp slime/swank-openmcl.lisp slime/swank-lispworks.lisp slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17536 Modified Files: swank-cmucl.lisp swank-sbcl.lisp swank-clisp.lisp swank-openmcl.lisp swank-lispworks.lisp swank-allegro.lisp Log Message: (format-condition-for-emacs): Replaced with debugger-condition-for-emacs. (backtrace): Use print-with-frame-label. (frame-locals): Rename the :symbol property to :name. Date: Fri Jan 2 13:23:14 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.42 slime/swank-cmucl.lisp:1.43 --- slime/swank-cmucl.lisp:1.42 Mon Dec 15 00:28:21 2003 +++ slime/swank-cmucl.lisp Fri Jan 2 13:23:14 2004 @@ -47,8 +47,9 @@ (system:add-fd-handler fd :input fn)) (defun accept-loop (fd background close) - "Accept clients on the the server socket FD. -Use fd-handlers if BACKGROUND is non-nil. Close the server socket after the first client if CLOSE is non-nil, " + "Accept clients on the the server socket FD. Use fd-handlers if +BACKGROUND is non-nil. Close the server socket after the first client +if CLOSE is non-nil, " (cond (background (add-input-handler fd (lambda (fd) (accept-one-client fd background close)))) @@ -415,29 +416,6 @@ xrefs))) (group-xrefs xrefs))) - -(defun location-buffer= (location1 location2) - (equalp location1 location2)) - -(defun file-xrefs-for-emacs (unix-filename contexts) - "Return a summary of the references from a particular file. -The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))" - (list unix-filename - (loop for context in (sort-contexts-by-source-path contexts) - collect (list (let ((*print-pretty* nil)) - (to-string (xref:xref-context-name context))) - (xref:xref-context-source-path context))))) - -(defun sort-contexts-by-source-path (contexts) - "Sort xref contexts by lexical position of source-paths. -It is assumed that all contexts belong to the same file." - (sort contexts #'source-path< :key #'xref:xref-context-source-path)) - -(defun source-path< (path1 path2) - "Return true if PATH1 is lexically before PATH2." - (and (every #'< path1 path2) - (< (length path1) (length path2)))) - (defun clear-xref-info (namestring) "Clear XREF notes pertaining to FILENAME. This is a workaround for a CMUCL bug: XREF records are cumulative." @@ -594,9 +572,9 @@ This is useful when debugging the definition-finding code.") (defmacro safe-definition-finding (&body body) - "Execute BODY ignoring errors. Return a the source location -returned by BODY or if an error occurs a description of the error. -The second return value is the condition or nil." + "Execute BODY ignoring errors. Return the source location returned +by BODY or if an error occurs a description of the error. The second +return value is the condition or nil." `(flet ((body () , at body)) (if *debug-definition-finding* (body) @@ -974,11 +952,6 @@ collect (list (princ-to-string (restart-name restart)) (princ-to-string restart)))) -(defun format-condition-for-emacs () - (format nil "~A~% [Condition of type ~S]" - (debug::safe-condition-message *swank-debugger-condition*) - (type-of *swank-debugger-condition*))) - (defun nth-frame (index) (do ((frame *sldb-stack-top* (di:frame-down frame)) (i index (1- i))) @@ -987,10 +960,10 @@ (defun nth-restart (index) (nth index *sldb-restarts*)) -(defun format-frame-for-emacs (frame) - (with-output-to-string (*standard-output*) - (let ((*print-pretty* *sldb-pprint-frames*)) - (debug::print-frame-call frame :verbosity 1 :number t)))) +(defun format-frame-for-emacs (number frame) + (print-with-frame-label + number (lambda (*standard-output*) + (debug::print-frame-call frame :verbosity 1 :number nil)))) (defun compute-backtrace (start end) "Return a list of frames starting with frame number START and @@ -1004,10 +977,10 @@ (defmethod backtrace (start end) (loop for (n . frame) in (compute-backtrace start end) - collect (list n (format-frame-for-emacs frame)))) + collect (list n (format-frame-for-emacs n frame)))) (defmethod debugger-info-for-emacs (start end) - (list (format-condition-for-emacs) + (list (debugger-condition-for-emacs) (format-restarts-for-emacs) (backtrace start end))) @@ -1031,15 +1004,14 @@ (location (di:frame-code-location frame)) (debug-function (di:frame-debug-function frame)) (debug-variables (di::debug-function-debug-variables debug-function))) - (loop for v across debug-variables - for symbol = (di:debug-variable-symbol v) - for id = (di:debug-variable-id v) - for validy = (di:debug-variable-validity v location) - collect (list :symbol symbol :id id - :value-string - (ecase validy - (:valid (to-string (di:debug-variable-value v frame))) - ((:invalid :unknown) "")))))) + (loop for v across debug-variables collect + (list :name (to-string (di:debug-variable-symbol v)) + :id (di:debug-variable-id v) + :value-string (ecase (di:debug-variable-validity v location) + (:valid + (to-string (di:debug-variable-value v frame))) + ((:invalid :unknown) + "")))))) (defmethod frame-catch-tags (index) (loop for (tag . code-location) in (di:frame-catches (nth-frame index)) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.44 slime/swank-sbcl.lisp:1.45 --- slime/swank-sbcl.lisp:1.44 Thu Dec 11 22:22:36 2003 +++ slime/swank-sbcl.lisp Fri Jan 2 13:23:14 2004 @@ -240,7 +240,7 @@ When Emacs presents the message it already has the source popped up and the source form highlighted. This makes much of the information in the error-context redundant." - (declare (type (or sb-c::compiler-error-context error-context null))) + (declare (type (or sb-c::compiler-error-context null) error-context)) (let ((enclosing (and error-context (sb-c::compiler-error-context-enclosing-source error-context)))) @@ -407,18 +407,6 @@ ;;; -(defun tracedp (fname) - (gethash (sb-debug::trace-fdefinition fname) - sb-debug::*traced-funs*)) - -(defslimefun toggle-trace-fdefinition (fname-string) - (let ((fname (from-string fname-string))) - (cond ((tracedp fname) - (sb-debug::untrace-1 fname) - (format nil "~S is now untraced." fname)) - (t - (sb-debug::trace-1 fname (sb-debug::make-trace-info)) - (format nil "~S is now traced." fname))))) (defslimefun getpid () (sb-unix:unix-getpid)) @@ -452,11 +440,6 @@ collect (list (princ-to-string (restart-name restart)) (princ-to-string restart)))) -(defun format-condition-for-emacs () - (format nil "~A~% [Condition of type ~S]" - (ignore-errors *swank-debugger-condition*) - (type-of *swank-debugger-condition*))) - (defun nth-frame (index) (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) (i index (1- i))) @@ -465,30 +448,27 @@ (defun nth-restart (index) (nth index *sldb-restarts*)) -(defun format-frame-for-emacs (frame) - (list (sb-di:frame-number frame) - (with-output-to-string (*standard-output*) - (let ((*print-pretty* *sldb-pprint-frames*)) - (sb-debug::print-frame-call frame :verbosity 1 :number t))))) +(defun format-frame-for-emacs (number frame) + (print-with-frame-label + number (lambda (*standard-output*) + (sb-debug::print-frame-call frame :verbosity 1 :number nil)))) (defun compute-backtrace (start end) "Return a list of frames starting with frame number START and continuing to frame number END or, if END is nil, the last frame on the stack." (let ((end (or end most-positive-fixnum))) - (do ((frame *sldb-stack-top* (sb-di:frame-down frame)) - (i 0 (1+ i))) - ((= i start) - (loop for f = frame then (sb-di:frame-down f) - for i from start below end - while f - collect f))))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f + collect (cons i f)))) (defmethod backtrace (start end) - (mapcar #'format-frame-for-emacs (compute-backtrace start end))) + (loop for (n . frame) in (compute-backtrace start end) + collect (list n (format-frame-for-emacs n frame)))) (defmethod debugger-info-for-emacs (start end) - (list (format-condition-for-emacs) + (list (debugger-condition-for-emacs) (format-restarts-for-emacs) (backtrace start end))) @@ -563,9 +543,8 @@ (debug-variables (sb-di::debug-fun-debug-vars debug-function))) (loop for v across debug-variables collect (list - :symbol (sb-di:debug-var-symbol v) + :name (to-string (sb-di:debug-var-symbol v)) :id (sb-di:debug-var-id v) - :validity (sb-di:debug-var-validity v location) :value-string (if (eq (sb-di:debug-var-validity v location) :valid) Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.1 slime/swank-clisp.lisp:1.2 --- slime/swank-clisp.lisp:1.1 Fri Jan 2 03:01:48 2004 +++ slime/swank-clisp.lisp Fri Jan 2 13:23:14 2004 @@ -222,10 +222,6 @@ ;;; (*print-length* 10)) (funcall debugger-loop-fn))) -(defun format-condition-for-emacs () - (format nil "~A~% [Condition of type ~S]" - *swank-debugger-condition* (type-of *swank-debugger-condition*))) - (defun format-restarts-for-emacs () (loop for restart in *sldb-restarts* collect (list (princ-to-string (restart-name restart)) @@ -248,12 +244,13 @@ (defmethod backtrace (start-frame-number end-frame-number) (flet ((format-frame (f i) - (format nil "~d: ~a" i - (string-left-trim - '(#\Newline) - (with-output-to-string (stream) - (let ((*print-pretty* *sldb-pprint-frames*)) - (sys::describe-frame stream f))))))) + (print-with-frame-label + i (lambda (s) + (princ (string-left-trim + '(#\Newline) + (with-output-to-string (stream) + (sys::describe-frame stream f))) + s))))) (loop for i from start-frame-number for f in (compute-backtrace start-frame-number end-frame-number) collect (list i (format-frame f i))))) @@ -275,18 +272,16 @@ ;; NIL or #(v1 val1 ... vn valn NEXT-ENV). (defun frame-do-venv (frame venv) - (loop - for i from 1 below (length venv) by 2 - as symbol = (svref venv (1- i)) - and value = (svref venv i) - collect (list :symbol symbol :id 0 - :value-string - (to-string - (if (eq sys::specdecl value) - ;; special variable - (sys::eval-at frame symbol) - ;; lexical variable or symbol macro - value))))) + (loop for i from 1 below (length venv) by 2 + as symbol = (svref venv (1- i)) + and value = (svref venv i) + collect (list :name (to-string symbol) :id 0 + :value-string (to-string + (if (eq sys::specdecl value) + ;; special variable + (sys::eval-at frame symbol) + ;; lexical variable or symbol macro + value))))) (defun frame-do-fenv (frame fenv) (declare (ignore frame fenv)) @@ -313,7 +308,7 @@ (nth-frame index)))) (defmethod debugger-info-for-emacs (start end) - (list (format-condition-for-emacs) + (list (debugger-condition-for-emacs) (format-restarts-for-emacs) (backtrace start end))) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.42 slime/swank-openmcl.lisp:1.43 --- slime/swank-openmcl.lisp:1.42 Fri Dec 19 00:50:18 2003 +++ slime/swank-openmcl.lisp Fri Jan 2 13:23:14 2004 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.42 2003/12/19 05:50:18 aruttenberg Exp $ +;;; $Id: swank-openmcl.lisp,v 1.43 2004/01/02 18:23:14 heller Exp $ ;;; ;;; @@ -281,10 +281,6 @@ collect (list (princ-to-string (restart-name restart)) (princ-to-string restart)))) -(defun format-condition-for-emacs () - (format nil "~A~% [Condition of type ~S]" - *swank-debugger-condition* (type-of *swank-debugger-condition*))) - (defun map-backtrace (function &optional (start-frame-number 0) (end-frame-number most-positive-fixnum)) @@ -351,15 +347,18 @@ (let (result) (map-backtrace (lambda (frame-number p tcr lfun pc) (push (list frame-number - (format nil "~D: (~A~A)" frame-number - (ccl::%lfun-name-string lfun) - (frame-arguments p tcr lfun pc))) + (print-with-frame-label + frame-number + (lambda (s) + (format s "(~A~A)" + (ccl::%lfun-name-string lfun) + (frame-arguments p tcr lfun pc))))) result)) start-frame-number end-frame-number) (nreverse result))) (defmethod debugger-info-for-emacs (start end) - (list (format-condition-for-emacs) + (list (debugger-condition-for-emacs) (format-restarts-for-emacs) (backtrace start end))) @@ -376,9 +375,8 @@ (declare (ignore type)) (when name (push (list - :symbol (to-string name) + :name (to-string name) :id 0 - :validity :valid :value-string (to-string var)) result)))) (return-from frame-locals (nreverse result)))))))) Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.9 slime/swank-lispworks.lisp:1.10 --- slime/swank-lispworks.lisp:1.9 Sun Dec 14 02:59:36 2003 +++ slime/swank-lispworks.lisp Fri Jan 2 13:23:14 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.9 2003/12/14 07:59:36 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.10 2004/01/02 18:23:14 heller Exp $ ;;; (in-package :swank) @@ -169,12 +169,6 @@ (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*))) (funcall fn)))) -(defun format-condition-for-emacs () - (let ((*print-right-margin* 75) - (*print-pretty* t)) - (format nil "~A~% [Condition of type ~S]" - *swank-debugger-condition* (type-of *swank-debugger-condition*)))) - (defun format-restarts-for-emacs () (loop for restart in *sldb-restarts* collect (list (princ-to-string (restart-name restart)) @@ -203,22 +197,21 @@ (defmethod backtrace (start end) (flet ((format-frame (f i) - (with-output-to-string (*standard-output*) - (let ((*print-pretty* *sldb-pprint-frames*)) - (format t "~D: ~A" i - (cond ((dbg::call-frame-p f) - (format nil "~A ~A" - (dbg::call-frame-function-name f) - (dbg::call-frame-arglist f))) - (t f))))))) + (print-with-frame-label + i (lambda (s) + (cond ((dbg::call-frame-p f) + (format s "~A ~A" + (dbg::call-frame-function-name f) + (dbg::call-frame-arglist f))) + (t (princ f s))))))) (loop for i from start for f in (compute-backtrace start end) collect (list i (format-frame f i))))) (defmethod debugger-info-for-emacs (start end) - (list (format-condition-for-emacs) + (list (debugger-condition-for-emacs) (format-restarts-for-emacs) - (backtrace start end))) + (backtrace start end))) (defun nth-restart (index) (nth index *sldb-restarts*)) @@ -233,7 +226,7 @@ (dbg::frame-locals-format-list frame #'list 75 0) (declare (ignore with)) (loop for (name value symbol location) in vars - collect (list :symbol symbol :id 0 + collect (list :name (to-string symbol) :id 0 :value-string (princ-to-string value))))))) (defmethod frame-catch-tags (index) Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.4 slime/swank-allegro.lisp:1.5 --- slime/swank-allegro.lisp:1.4 Sun Dec 14 02:58:12 2003 +++ slime/swank-allegro.lisp Fri Jan 2 13:23:14 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.4 2003/12/14 07:58:12 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.5 2004/01/02 18:23:14 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -36,6 +36,8 @@ ;;; TCP Server +(setq *start-swank-in-background* nil) + (defun create-swank-server (port &key (reuse-address t) (announce #'simple-announce-function) (background *start-swank-in-background*) @@ -145,10 +147,6 @@ (*print-length* 10)) (funcall debugger-loop-fn))) -(defun format-condition-for-emacs () - (format nil "~A~% [Condition of type ~S]" - *swank-debugger-condition* (type-of *swank-debugger-condition*))) - (defun format-restarts-for-emacs () (loop for restart in *sldb-restarts* collect (list (princ-to-string (restart-name restart)) @@ -168,16 +166,14 @@ (defmethod backtrace (start-frame-number end-frame-number) (flet ((format-frame (f i) - (with-output-to-string (stream) - (let ((*print-pretty* *sldb-pprint-frames*)) - (format stream "~D: " i) - (debugger:output-frame stream f :moderate))))) + (print-with-frame-label + i (lambda (s) (debugger:output-frame s f :moderate))))) (loop for i from start-frame-number for f in (compute-backtrace start-frame-number end-frame-number) collect (list i (format-frame f i))))) (defmethod debugger-info-for-emacs (start end) - (list (format-condition-for-emacs) + (list (debugger-condition-for-emacs) (format-restarts-for-emacs) (backtrace start end))) @@ -193,7 +189,7 @@ (defmethod frame-locals (index) (let ((frame (nth-frame index))) (loop for i from 0 below (debugger:frame-number-vars frame) - collect (list :symbol (debugger:frame-var-name frame i) + collect (list :name (to-string (debugger:frame-var-name frame i)) :id 0 :value-string (to-string (debugger:frame-var-value frame i)))))) From heller at common-lisp.net Fri Jan 2 18:24:21 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 02 Jan 2004 13:24:21 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv608 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 2 13:24:21 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.182 slime/ChangeLog:1.183 --- slime/ChangeLog:1.182 Fri Jan 2 05:02:50 2004 +++ slime/ChangeLog Fri Jan 2 13:24:21 2004 @@ -1,5 +1,72 @@ 2004-01-02 Helmut Eller + * slime.el (slime-display-output-buffer): Move the output markers + to the end of the buffer. + + * swank-clisp.lisp (frame-do-venv): Rename the :symbol property to + :name. + (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + + * swank-openmcl.lisp (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + (frame-locals): Rename the :symbol property to :name. + + * swank-lispworks.lisp (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + (frame-locals): Rename the :symbol property to :name. + + * swank-allegro.lisp (frame-locals): Rename the :symbol property + to :name. + (format-condition-for-emacs): Replaced with + debugger-condition-for-emacs. + (backtrace): Use print-with-frame-label. + + * swank-sbcl.lisp (tracedp, toggle-trace-fdefinition) + (format-condition-for-emacs): Remove unused functions. + (format-frame-for-emacs): Use print-with-frame-label. + (compute-backtrace): Simplified. + (backtrace): Return our frame numbers. + (frame-locals): Rename the :symbol property to :name. Remove the + :validity property. + + * swank-cmucl.lisp (accept-loop, safe-definition-finding): Doc + fix. + (location-buffer=, file-xrefs-for-emacs) + (sort-contexts-by-source-path, source-path<) + (format-condition-for-emacs): Remove unused functions. + (format-frame-for-emacs): Don't include the frame number in the + description, but use the frame number for indentation. Update + callers. + (frame-locals): Rename the :symbol property to :name. + + * slime.el (slime-add-face): New function. + (sldb-add-face): Use it. + (sldb-setup): Some refactoring. + (sldb-insert-condition): New function. Factorized from + sldb-setup. Message and types are now separate. + (sldb-insert-restarts): New function. Factorized from sldb-setup. + (sldb-insert-frame): Factorized from slime-insert-frames. The + frame number in no longer part of the string describing the frame. + (sldb-insert-frames): Use it. + (sldb-show-frame-details): Print frame numbers. Fix printing of + catch tags. Move to the start of the frame before at the + beginning to get unfontified text properties. + (sldb-inspect-condition): New command. + (sldb-insert-locals): The :symbol property is now called :name. + Fix locals with :id attribute. + (slime-open-inspector): Fix the bugs I introduced last time. + + * swank.lisp (safe-condition-message): New function. + (debugger-condition-for-emacs): Used to be + format-condition-for-emacs in each backend. Separate the + condition message from the type description. Update all backends + accordingly. + (print-with-frame-label): New function. + * slime.el (slime-hyperspec-lookup): New function. 2004-01-02 Wolfgang Jenkner From Jenna_Kein55 at hotmail.com Fri Jan 2 22:33:10 2004 From: Jenna_Kein55 at hotmail.com (Jenna Kein) Date: Fri, 02 Jan 04 22:33:10 GMT Subject: [slime-cvs] Buy your c1garettes for much less Message-ID: An HTML attachment was scrubbed... URL: From Eddi_Kar55 at hotmail.com Mon Jan 5 03:15:15 2004 From: Eddi_Kar55 at hotmail.com (Eddi Kar) Date: Mon, 05 Jan 04 03:15:15 GMT Subject: [slime-cvs] GET YOUR UN_IVERSITY DI_PLOMA Message-ID: <0a219d7042--vd3-li49j@y7i4l.sse> An HTML attachment was scrubbed... URL: From lgorrie at common-lisp.net Mon Jan 5 20:51:50 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 05 Jan 2004 15:51:50 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14369 Modified Files: ChangeLog Log Message: Date: Mon Jan 5 15:51:50 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.183 slime/ChangeLog:1.184 --- slime/ChangeLog:1.183 Fri Jan 2 13:24:21 2004 +++ slime/ChangeLog Mon Jan 5 15:51:50 2004 @@ -1,3 +1,43 @@ +2004-01-05 Luke Gorrie + + * slime.el: Multiple session support, i.e. Emacs can open + multiple connections to Lisps. The guts is there, but + user-interface is currently minimal. + (slime-net-process): Replaced with slime-net-processes. + (slime-net-send): Take process as argument. + (slime-process-available-input): Poll all connections. + (slime-connection): Current connection (process) to use for + talking to Lisp. Can be bound dynamically or buffer-local. + (slime-with-connection-buffer): Macro to enter the process-buffer + of `slime-connection' to manipulate the local variables. + (slime-stack-stack): Now buffer-local in the process-buffer of + each connection. + (slime-push-state, slime-pop-state): Operate on the stack inside + `slime-connection's process-buffer. + (slime-dispatch-event): Take optional process argument, to bind + `slime-connection' appropriately when events arrive from the + network. + (slime-def-connection-var): Macro to define variables that are + "connection-local". Such variables are used via (setf'able) + accessor functions, and their real bindings exist as local + variables in the process-buffers of connections. The accessors + automatically work on `slime-connection'. + (slime-lisp-features, slime-lisp-package, slime-pid, sldb-level): + These variables are now connection-local. + (slime-read-from-minibuffer): Inherit `slime-connection' as + buffer-local so that we complete towards the right Lisp. + (sldb-mode): Inherit `slime-connection' as buffer-local so that we + debug towards the right Lisp. + (get-sldb-buffer): New function to return (optionally create) the + SLDB buffer for the current connection. Since multiple Lisps can + be debugged simultaneously, the buffername now includes the + connection number. + (slime-connection-abort): New command to abort a connection + attempt (don't use `slime-disconnect' anymore - that closes all + connections). + (slime-execute-tests): Honor `slime-test-debug-on-error'. + (slime-next-connection): Cycle through open Lisp connections. + 2004-01-02 Helmut Eller * slime.el (slime-display-output-buffer): Move the output markers @@ -98,6 +138,7 @@ (slime-open-inspector): Minor indentation fixes. (slime-net-output-funcall): Removed. Was unused. +>>>>>>> 1.183 2003-12-19 Alan Ruttenberg * slime.el 1.157 fix bug in sldb-princ-locals I introduced when adding fonts to sldb From lgorrie at common-lisp.net Mon Jan 5 20:51:44 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 05 Jan 2004 15:51:44 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14091 Modified Files: slime.el Log Message: Multiple session support, i.e. Emacs can open multiple connections to Lisps. The guts is there, but user-interface is currently minimal. (slime-net-process): Replaced with slime-net-processes. (slime-net-send): Take process as argument. (slime-process-available-input): Poll all connections. (slime-connection): Current connection (process) to use for talking to Lisp. Can be bound dynamically or buffer-local. (slime-with-connection-buffer): Macro to enter the process-buffer of `slime-connection' to manipulate the local variables. (slime-stack-stack): Now buffer-local in the process-buffer of each connection. (slime-push-state, slime-pop-state): Operate on the stack inside `slime-connection's process-buffer. (slime-dispatch-event): Take optional process argument, to bind `slime-connection' appropriately when events arrive from the network. (slime-def-connection-var): Macro to define variables that are "connection-local". Such variables are used via (setf'able) accessor functions, and their real bindings exist as local variables in the process-buffers of connections. The accessors automatically work on `slime-connection'. (slime-lisp-features, slime-lisp-package, slime-pid, sldb-level): These variables are now connection-local. (slime-read-from-minibuffer): Inherit `slime-connection' as buffer-local so that we complete towards the right Lisp. (sldb-mode): Inherit `slime-connection' as buffer-local so that we debug towards the right Lisp. (get-sldb-buffer): New function to return (optionally create) the SLDB buffer for the current connection. Since multiple Lisps can be debugged simultaneously, the buffername now includes the connection number. (slime-connection-abort): New command to abort a connection attempt (don't use `slime-disconnect' anymore - that closes all connections). (slime-execute-tests): Honor `slime-test-debug-on-error'. (slime-next-connection): Cycle through open Lisp connections. Date: Mon Jan 5 15:51:44 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.160 slime/slime.el:1.161 --- slime/slime.el:1.160 Fri Jan 2 13:20:12 2004 +++ slime/slime.el Mon Jan 5 15:51:44 2004 @@ -1,5 +1,5 @@ -;; -*- mode: emacs-lisp; mode: outline-minor; outline-regexp: ";;;;*"; indent-tabs-mode: nil -*- -;; slime.el -- Superior Lisp Interaction Mode, Extended +;;; -*- 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 ;; @@ -87,21 +87,6 @@ Don't access this value directly in a program. Call the function with the same name instead.")) -(defvar slime-lisp-features nil - "The symbol names in the *FEATURES* list of the Superior lisp. -This is needed to READ Common Lisp expressions adequately.") - -(defvar slime-default-lisp-package "CL-USER" - "The default and initial package for the REPL.") - -(defvar slime-lisp-package - slime-default-lisp-package - "The current package name of the Superior lisp. -This is automatically synchronized from Lisp.") - -(defvar slime-pid nil - "The process id of the Lisp process.") - (defvar slime-dont-prompt nil "When true, don't prompt the user for input during startup. This is used for batch-mode testing.") @@ -308,7 +293,7 @@ '((" " 'undefined))) -;;;; inferior-slime-mode +;;;;; inferior-slime-mode (define-minor-mode inferior-slime-mode "\\ Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs. @@ -393,7 +378,7 @@ (comint-send-input)) -;;;; Key bindings +;;;;; Key bindings ;; See `slime-define-key' below for keyword meanings. (defvar slime-keys @@ -482,51 +467,51 @@ (slime-init-keymaps) -;;;; Pull-down menu +;;;;; Pull-down menu (defvar slime-easy-menu (let ((C '(slime-connected-p))) `("SLIME" - [ "Edit Definition..." slime-edit-fdefinition ,C ] - [ "Return From Definition" slime-pop-find-definition-stack ,C ] - [ "Complete Symbol" slime-complete-symbol ,C ] + [ "Edit Definition..." slime-edit-fdefinition ,C ] + [ "Return From Definition" slime-pop-find-definition-stack ,C ] + [ "Complete Symbol" slime-complete-symbol ,C ] "--" ("Evaluation" - [ "Eval Defun" slime-eval-defun ,C ] - [ "Eval Last Expression" slime-eval-last-expression ,C ] - [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] - [ "Interactive Eval" slime-interactive-eval ,C ]) + [ "Eval Defun" slime-eval-defun ,C ] + [ "Eval Last Expression" slime-eval-last-expression ,C ] + [ "Eval And Pretty-Print" slime-pprint-eval-last-expression ,C ] + [ "Interactive Eval" slime-interactive-eval ,C ]) ("Debugging" - [ "Macroexpand Once..." slime-macroexpand-1 ,C ] - [ "Macroexpand All..." slime-macroexpand-all ,C ] - [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] - [ "Disassemble..." slime-disassemble-symbol ,C ] - [ "Inspect..." slime-inspect ,C ]) + [ "Macroexpand Once..." slime-macroexpand-1 ,C ] + [ "Macroexpand All..." slime-macroexpand-all ,C ] + [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ] + [ "Disassemble..." slime-disassemble-symbol ,C ] + [ "Inspect..." slime-inspect ,C ]) ("Compilation" - [ "Compile Defun" slime-compile-defun ,C ] - [ "Compile/Load File" slime-compile-and-load-file ,C ] - [ "Compile File" slime-compile-file ,C ] + [ "Compile Defun" slime-compile-defun ,C ] + [ "Compile/Load File" slime-compile-and-load-file ,C ] + [ "Compile File" slime-compile-file ,C ] "--" - [ "Next Note" slime-next-note t ] - [ "Previous Note" slime-previous-note t ] - [ "Remove Notes" slime-remove-notes t ]) + [ "Next Note" slime-next-note t ] + [ "Previous Note" slime-previous-note t ] + [ "Remove Notes" slime-remove-notes t ]) ("Cross Reference" - [ "Who Calls..." slime-who-calls ,C ] - [ "Who References... " slime-who-references ,C ] - [ "Who Sets..." slime-who-sets ,C ] - [ "Who Binds..." slime-who-binds ,C ] - [ "Who Macroexpands..." slime-who-macroexpands ,C ] - [ "Who Specializes..." slime-who-specializes ,C ] - [ "List Callers..." slime-list-callers ,C ] - [ "List Callees..." slime-list-callees ,C ] - [ "Next Location" slime-next-location t ]) + [ "Who Calls..." slime-who-calls ,C ] + [ "Who References... " slime-who-references ,C ] + [ "Who Sets..." slime-who-sets ,C ] + [ "Who Binds..." slime-who-binds ,C ] + [ "Who Macroexpands..." slime-who-macroexpands ,C ] + [ "Who Specializes..." slime-who-specializes ,C ] + [ "List Callers..." slime-list-callers ,C ] + [ "List Callees..." slime-list-callees ,C ] + [ "Next Location" slime-next-location t ]) ("Documentation" - [ "Describe Symbol..." slime-describe-symbol ,C ] - [ "Apropos..." slime-apropos ,C ] - [ "Hyperspec..." hyperspec-lookup t ]) + [ "Describe Symbol..." slime-describe-symbol ,C ] + [ "Apropos..." slime-apropos ,C ] + [ "Hyperspec..." slime-hyperspec-lookup t ]) "--" - [ "Interrupt Command" slime-interrupt ,C ] - [ "Abort Async. Command" slime-quit ,C ] + [ "Interrupt Command" slime-interrupt ,C ] + [ "Abort Async. Command" slime-quit ,C ] [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C] ))) @@ -636,7 +621,7 @@ slime-buffer-package (which may also be nil). The REPL buffer is a special case: it's package is `slime-lisp-package'." - (or (and (eq major-mode 'slime-repl-mode) slime-lisp-package) + (or (and (eq major-mode 'slime-repl-mode) (slime-lisp-package)) (let ((string (slime-find-buffer-package))) (cond (string (cond (dont-cache) @@ -811,17 +796,22 @@ ("q" 'slime-temp-buffer-quit)) (defmacro slime-with-output-to-temp-buffer (name &rest body) - "Like `with-output-to-temp-buffer', but saves the window configuration." + "Similar to `with-output-to-temp-buffer'. +Also saves the window configuration, and inherts the current +`slime-connection' in a buffer-local variable." (let ((config (gensym))) `(let ((,config (current-window-configuration)) + (connection slime-connection) (standard-output (with-current-buffer (get-buffer-create ,name) (setq buffer-read-only nil) (erase-buffer) (current-buffer)))) (prog1 (progn , at body) (with-current-buffer standard-output - (make-local-variable 'slime-temp-buffer-saved-window-configuration) - (setq slime-temp-buffer-saved-window-configuration ,config) + (set (make-local-variable 'slime-connection) + connection) + (set (make-local-variable 'slime-temp-buffer-saved-window-configuration) + ,config) (goto-char (point-min)) (slime-mode 1) (set-syntax-table lisp-mode-syntax-table) @@ -860,10 +850,6 @@ `(swank:list-all-package-names))) nil nil initial-value))) -(defun slime-lisp-package () - "Return the name of the current REPL package." - slime-lisp-package) - (defmacro slime-propertize-region (props &rest body) (let ((start (gensym))) `(let ((,start (point))) @@ -879,7 +865,7 @@ ;;; Inferior CL Setup: compiling and connecting to Swank -(defvar slime-startup-retry-timer nil +(defvar slime-connect-retry-timer nil "Timer object while waiting for an inferior-lisp to start.") (defun slime () @@ -889,7 +875,6 @@ (slime-disconnect)) (slime-maybe-start-lisp) (slime-maybe-start-multiprocessing) - (setq slime-lisp-package slime-default-lisp-package) (slime-read-port-and-connect)) (defun slime-maybe-start-lisp () @@ -941,13 +926,13 @@ () (unless (active-minibuffer-window) (message "\ -Polling %S.. (Abort with `M-x slime-disconnect'.)" +Polling %S.. (Abort with `M-x slime-connection-abort'.)" (slime-swank-port-file))) (setq slime-state-name (format "[polling:%S]" (incf attempt))) (force-mode-line-update) - (when slime-startup-retry-timer - (cancel-timer slime-startup-retry-timer)) - (setq slime-startup-retry-timer nil) ; remove old timer + (when slime-connect-retry-timer + (cancel-timer slime-connect-retry-timer)) + (setq slime-connect-retry-timer nil) ; remove old timer (cond ((file-exists-p (slime-swank-port-file)) (let ((port (slime-read-swank-port))) (delete-file (slime-swank-port-file)) @@ -956,44 +941,40 @@ (message "Failed to connect to Swank.")) (t (when retries (decf retries)) - (setq slime-startup-retry-timer + (setq slime-connect-retry-timer (run-with-timer 1 nil #'attempt-connection)))))) (attempt-connection)))) -(defun slime-connect (host port) +(defun slime-connect (host port &optional kill-old-p) "Connect to a running Swank server" (interactive (list (read-from-minibuffer "Host: " "localhost") - (read-from-minibuffer "Port: " "4005" nil t))) + (read-from-minibuffer "Port: " "4005" nil t) + (if (null slime-net-processes) + t + (y-or-n-p "Close old connections first? ")))) + (when kill-old-p (slime-disconnect)) (message "Connecting to Swank on port %S.." port) - (slime-net-connect "localhost" port) - (slime-init-connection) + (slime-init-connection (slime-net-connect "localhost" port)) (when-let (buffer (get-buffer "*inferior-lisp*")) (delete-windows-on buffer) - (bury-buffer (get-buffer "*inferior-lisp*"))) + (bury-buffer buffer)) (pop-to-buffer (slime-output-buffer)) (message "Connected to Swank server on port %S. %s" port (slime-random-words-of-encouragement))) (defun slime-disconnect () - "Disconnect from the Swank server." + "Disconnect all connections." (interactive) - (cond ((slime-connected-p) - (kill-buffer (process-buffer slime-net-process)) - (delete-process slime-net-process) - (message "Disconnected.")) - (slime-startup-retry-timer - (cancel-timer slime-startup-retry-timer) - (message "Cancelled connection attempt.")) - (t - (message "Not connected."))) - (when-let (stream (get-process "*lisp-output-stream*")) - (delete-process stream))) + (mapc #'slime-net-close slime-net-processes)) -(defun slime-init-connection () - (slime-init-dispatcher) - (setq slime-pid (slime-eval '(swank:getpid))) - (when slime-global-debugger-hook - (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER"))) +(defun slime-connection-abort () + "Abort connection the current connection attempt." + (interactive) + (if (null slime-connect-retry-timer) + (error "Not connected.") + (cancel-timer slime-connect-retry-timer) + (message "Cancelled connection attempt."))) +;; FIXME: used to delete *lisp-output-stream* (defvar slime-words-of-encouragement '("Let the hacking commence!" @@ -1011,22 +992,25 @@ ;;; Networking -(defvar slime-net-process nil - "The process (socket) connected to the CL.") +(defvar slime-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar slime-net-process-close-hooks '() + "List of functions called when a slime network connection closes. +The functions are called with the process as their argument.") (defun slime-net-connect (host port) "Establish a connection with a CL." - (setq slime-net-process - (open-network-stream "SLIME Lisp" nil host port)) - (let ((buffer (slime-make-net-buffer " *cl-connection*"))) - (set-process-buffer slime-net-process buffer) - (set-process-filter slime-net-process 'slime-net-filter) - (set-process-sentinel slime-net-process 'slime-net-sentinel) + (let* ((proc (open-network-stream "SLIME Lisp" nil host port)) + (buffer (slime-make-net-buffer " *cl-connection*"))) + (push proc slime-net-processes) + (set-process-buffer proc buffer) + (set-process-filter proc 'slime-net-filter) + (set-process-sentinel proc 'slime-net-sentinel) (when (fboundp 'set-process-coding-system) - (set-process-coding-system slime-net-process - 'no-conversion 'no-conversion))) - slime-net-process) - + (set-process-coding-system proc 'no-conversion 'no-conversion)) + proc)) + (defun slime-make-net-buffer (name) "Make a buffer suitable for a network process." (let ((buffer (generate-new-buffer name))) @@ -1036,24 +1020,31 @@ (buffer-disable-undo)) buffer)) -(defun slime-net-send (sexp) - "Send a SEXP to inferior CL. +(defun slime-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. This is the lowest level of communication. The sexp will be READ and EVAL'd by Lisp." (let* ((msg (format "%S\n" sexp)) - (string (concat (slime-net-enc3 (length msg)) msg))) - (process-send-string slime-net-process (string-make-unibyte string)))) + (string (concat (slime-net-enc3 (length msg)) msg))) + (process-send-string proc (string-make-unibyte string)))) + +(defun slime-net-close (process) + (setq slime-net-processes (remove process slime-net-processes)) + (run-hook-with-args 'slime-net-process-close-hooks process) + (ignore-errors (kill-buffer (process-buffer process)))) + (defun slime-net-sentinel (process message) (when (ignore-errors (eq (process-status (inferior-lisp-proc)) 'open)) (message "Lisp connection closed unexpectedly: %s" message)) - (setq slime-state-name "[not connected]") + (when (eq process slime-primary-connection) + (setq slime-state-name "[not connected]")) (force-mode-line-update) - (ignore-errors (kill-buffer (process-buffer slime-net-process)))) + (slime-net-close process)) (defun slime-net-filter (process string) "Accept output from the socket and input all complete messages." - (with-current-buffer (process-buffer slime-net-process) + (with-current-buffer (process-buffer process) (save-excursion (goto-char (point-max)) (insert string)) @@ -1061,15 +1052,19 @@ (defun slime-process-available-input () "Process all complete messages that have arrived from Lisp." - (with-current-buffer (process-buffer slime-net-process) - (unwind-protect - (while (slime-net-have-input-p) - (let ((event (condition-case error - (slime-net-read) - (error (slime-state/event-panic error))))) - (save-current-buffer (slime-dispatch-event event)))) - (when (slime-net-have-input-p) - (run-at-time 0 nil 'slime-process-available-input))))) + (unwind-protect + (dolist (proc slime-net-processes) + (with-current-buffer (process-buffer proc) + (while (slime-net-have-input-p) + (let ((event (condition-case error + (slime-net-read) + (error (slime-state/event-panic error proc))))) + (save-current-buffer (slime-dispatch-event event proc)))))) + (when (some (lambda (p) + (with-current-buffer (process-buffer p) + (slime-net-have-input-p))) + slime-net-processes) + (run-at-time 0 nil 'slime-process-available-input)))) (defun slime-net-have-input-p () "Return true if a complete message is available." @@ -1101,6 +1096,126 @@ (logand n 255))) +;;; Connections + +;; High-level network connection management. +;; Handles multiple connections and "context-switching" between them. + +(defvar slime-connection nil + "Network process currently in use. +This connection is used to make requests when the user invokes +commands. + +Can be bound dynamically to use a particular connection temporarily. + +Can be bound buffer-locally to make a particular connection +\"sticky\" for commands in a particular buffer.") + +(defvar slime-primary-connection nil + "Network process selected for top-level use. +This variable is only used to test whether some process is the +primary process.") + +(defvar slime-connection-counter 0 + "Number of SLIME connections made, for generating serial numbers.") + +(make-variable-buffer-local + (defvar slime-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.")) + +(defun slime-connection-number (&optional connection) + (slime-with-connection-buffer (connection) + slime-connection-number)) + +(defvar slime-state-name "[??]" + "Name of the current state of `slime-primary-connection'. +For display in the mode-line.") + +(defmacro* slime-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `slime-connection' is used." + `(with-current-buffer + (process-buffer (or ,process slime-connection (error "No connection"))) + , at body)) + +(defun slime-select-connection (process) + (setq slime-connection process) + (setq slime-primary-connection process) + (let ((message (format "Selected connection: %S" (slime-connection-number)))) + (unless (get-buffer-window (slime-output-buffer) t) + (message message)))) + +(defun slime-connection-close-hook (process) + (when (eq process slime-connection) + (setq slime-connection nil)) + (when (eq process slime-primary-connection) + (setq slime-primary-connection nil))) + +(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) + +(defun slime-next-connection () + "Use the next available Swank connection. +This command is mostly intended for debugging the multi-session code." + (interactive) + (when (null slime-net-processes) + (error "Not connected.")) + (let ((conn (nth (mod (1+ (or (position slime-connection slime-net-processes) 0)) + (length slime-net-processes)) + slime-net-processes))) + (slime-select-connection conn))) + +(put 'slime-with-connection-buffer 'lisp-indent-function 1) + + +;;;;; Connection-local variables + +;; Variables whose values are tied to a particular connection are +;; stored as buffer-local inside the connection's process-buffer, +;; and only read/written through accessor functions. + +(defmacro slime-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of +the same name (it must not be accessed directly). The accessor +function is setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `slime-connection'." + (let ((real-var (intern (format "%s:connlocal" varname)))) + `(progn + ;; Variable + (make-variable-buffer-local + (defvar ,real-var , at initial-value-and-doc)) + ;; Accessor + (defun ,varname () + (slime-with-connection-buffer () ,real-var)) + ;; Setf + (defsetf ,varname () (store) + `(slime-with-connection-buffer () + (setq ,',real-var ,store) + ,store)) + ',varname))) + +(slime-def-connection-var slime-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-lisp-package + "COMMON-LISP-USER" + "The current package name of the Superior lisp. +This is automatically synchronized from Lisp.") + +(slime-def-connection-var slime-pid nil + "The process id of the Lisp process.") + +(slime-def-connection-var sldb-level 0 + "Lisp's recursion depth in the SLDB loop.") + +(put 'slime-def-connection-var 'lisp-indent-function 2) + + ;;; Evaluation mechanics ;; The SLIME protocol is implemented with a small state machine. That @@ -1141,49 +1256,70 @@ ;; a special function instead of reaching the state machine. -;;;; Basic state machine framework +;;;;; Basic state machine framework -(defvar slime-state-stack '() - "Stack of machine states. The state at the top is the current state.") - -(defvar slime-state-name "[??]" - "The name of the current state, for display in the modeline.") +(make-variable-buffer-local + (defvar slime-state-stack '() + "Stack of machine states. The state at the top is the current state.")) (defun slime-push-state (state) "Push into a new state, saving the current state on the stack. This may be called by a state machine to cause a state change." - (push state slime-state-stack) + (slime-with-connection-buffer () + (push state slime-state-stack)) (slime-activate-state)) (defun slime-pop-state () "Pop back to the previous state from the stack. This may be called by a state machine to finish its current state." - (pop slime-state-stack) + (slime-with-connection-buffer () + (pop slime-state-stack)) (slime-activate-state)) (defun slime-current-state () - "The current state." - (car slime-state-stack)) + "The current state of the current connection." + (slime-with-connection-buffer () + (car slime-state-stack))) + +(defun slime-state-stack () + "Return the state stack for the current connection." + (slime-with-connection-buffer () + slime-state-stack)) -(defun slime-init-dispatcher () +(defun slime-init-connection (proc) "Initialize the stack machine." - (setq sldb-level 0) - (setq slime-state-stack (list (slime-idle-state))) - (sldb-cleanup)) - + (let ((slime-connection proc)) + (slime-init-connection-state) + (sldb-cleanup)) + (when (null slime-connection) + (slime-select-connection proc))) + +(defun slime-init-connection-state () + (slime-with-connection-buffer () + (setq slime-state-stack (list (slime-idle-state))) + (setq slime-connection-number (incf slime-connection-counter))) + (setf (slime-pid) (slime-eval '(swank:getpid))) + (when slime-global-debugger-hook + (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER")) + (setf (sldb-level) 0)) + (defun slime-activate-state () "Activate the current state. This delivers an (activate) event to the state function, and updates the state name for the modeline." (let ((state (slime-current-state))) + (slime-update-state-name) + (slime-dispatch-event '(activate)))) + +(defun slime-update-state-name () + (slime-with-connection-buffer (slime-primary-connection) (setq slime-state-name (ecase (slime-state-name state) (slime-idle-state "") (slime-evaluating-state "[eval...]") (slime-debugging-state "[debug]") (slime-read-string-state "[read]"))) - (force-mode-line-update) - (slime-dispatch-event '(activate)))) + (force-mode-line-update))) ;; state datastructure (defun slime-make-state (name function) @@ -1199,15 +1335,16 @@ (third state)) -;;;;; Event dispatching. +;;;;;;; Event dispatching. -(defun slime-dispatch-event (event) +(defun slime-dispatch-event (event &optional process) "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going into the state machine." - (slime-log-event event) - (or (slime-handle-oob event) - (funcall (slime-state-function (slime-current-state)) event))) + (let ((slime-connection (or process slime-connection))) + (slime-log-event event) + (unless (slime-handle-oob event) + (funcall (slime-state-function (slime-current-state)) event)))) (defun slime-handle-oob (event) "Handle out-of-band events. @@ -1217,19 +1354,20 @@ (slime-output-string output) t) ((:new-package package) - (setq slime-lisp-package package) + (setf (slime-lisp-package) package) t) ((:new-features features) - (setq slime-lisp-features features) + (setf (slime-lisp-features) features) t) ((:%apply fn args) (apply (intern fn) args) t) ((:awaiting-goahead thread-id thread-name reason) - (slime-register-waiting-thread thread-id thread-name reason)) + (slime-register-waiting-thread thread-id thread-name reason) + t) (t nil))) -(defun slime-state/event-panic (event) +(defun slime-state/event-panic (event process) "Signal the error that we received EVENT in a state that can't handle it. When this happens it is due to a bug in SLIME. @@ -1269,19 +1407,18 @@ " (pp-to-string event) - (pp-to-string (mapcar 'slime-state-name - slime-state-stack)) + (pp-to-string (mapcar 'slime-state-name (slime-state-stack))) (cond ((get-buffer "*slime-events*") (with-current-buffer "*slime-events*" (buffer-string))) (t "")) - (cond ((process-buffer slime-net-process) + (cond ((process-buffer process) (with-current-buffer - (process-buffer slime-net-process) + (process-buffer process) (buffer-string))) (t "")) ))) - (slime-disconnect) + (slime-net-close process) (display-buffer "*SLIME bug*") (delete-other-windows (get-buffer-window "*SLIME bug*")) (error "The SLIME protocol reached an inconsistent state.")) @@ -1290,7 +1427,7 @@ "*Log protocol events to the *slime-events* buffer.") -;;;;; Event logging to *slime-events* +;;;;;;; Event logging to *slime-events* (defun slime-log-event (event) (when slime-log-events (with-current-buffer (slime-events-buffer) @@ -1319,7 +1456,7 @@ (current-buffer))))) -;;;; Upper layer macros for defining states +;;;;; Upper layer macros for defining states (eval-when (compile eval) (defun slime-make-state-function (arglist clauses) @@ -1337,7 +1474,8 @@ '( ((activate) nil)) ) (t ;; Illegal event for current state. This is a BUG! - (slime-state/event-panic ,event-var)))))))) + (slime-state/event-panic ,event-var + slime-connection)))))))) (defmacro slime-defstate (name variables doc &rest events) "Define a state called NAME and comprised of VARIABLES. @@ -1351,13 +1489,7 @@ (put 'slime-defstate 'lisp-indent-function 2) -;;;; The SLIME state machine definition - -(defvar sldb-level 0 - "Current debug level, or 0 when not debugging.") - -(defvar sldb-level-in-buffer nil - "Buffer local variable in sldb buffer.") +;;;;; The SLIME state machine definition (defvar slime-stack-eval-tags nil "List of stack-tags of continuations waiting on the stack.") @@ -1365,7 +1497,7 @@ (slime-defstate slime-idle-state () "Idle state. The user may make a request, or Lisp may invoke the debugger." ((activate) - (assert (= sldb-level 0)) + (assert (= (sldb-level) 0)) (slime-repl-activate)) ((:debug level condition restarts frames) (slime-push-state @@ -1422,17 +1554,17 @@ Lisp entered the debugger while handling one of our requests. This state interacts with it until it is coaxed into returning." ((activate) - (let ((sldb-buffer (get-buffer "*sldb*"))) + (let ((sldb-buffer (get-sldb-buffer))) (when (or (not sldb-buffer) - (/= sldb-level level) + (/= (sldb-level) level) (with-current-buffer sldb-buffer (/= level sldb-level-in-buffer))) - (setq sldb-level level) + (setf (sldb-level) level) (sldb-setup condition restarts frames)))) ((:debug-return level) - (assert (= level sldb-level)) + (assert (= level (sldb-level))) (sldb-cleanup) - (decf sldb-level) + (decf (sldb-level)) (set-window-configuration saved-window-configuration) (slime-pop-state)) ((:emacs-evaluate form-string package-name continuation) @@ -1448,7 +1580,7 @@ ((activate) (slime-repl-read-string)) ((:emacs-return-string code) - (slime-net-send `(swank:take-input ,tag ,code)) + (slime-net-send `(swank:take-input ,tag ,code) slime-connection) (slime-pop-state)) ((:emacs-evaluate form-string package-name continuation) (slime-output-evaluate-request form-string package-name) @@ -1460,15 +1592,15 @@ (slime-pop-state))) -;;;; Utilities +;;;;; Utilities (defun slime-output-evaluate-request (form-string package-name) "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." - (slime-net-send `(swank:eval-string ,form-string ,package-name))) + (slime-send `(swank:eval-string ,form-string ,package-name))) (defun slime-output-oneway-evaluate-request (form-string package-name) "Like `slime-output-oneway-evaluate-request' but without expecting a result." - (slime-net-send `(swank:oneway-eval-string ,form-string ,package-name))) + (slime-send `(swank:oneway-eval-string ,form-string ,package-name))) (defun slime-check-connected () (unless (slime-connected-p) @@ -1476,8 +1608,7 @@ (defun slime-connected-p () "Return true if the Swank connection is open." - (and slime-net-process - (eq (process-status slime-net-process) 'open))) + (not (null slime-net-processes))) (defun slime-eval-string-async (string package continuation) (when (slime-busy-p) @@ -1487,10 +1618,10 @@ (defconst +slime-sigint+ 2) (defun slime-send-sigint () - (signal-process slime-pid +slime-sigint+)) + (signal-process (slime-pid) +slime-sigint+)) -;;;; Emacs Lisp programming interface +;;;;; Emacs Lisp programming interface (defun slime-eval (sexp &optional package) "Evaluate EXPR on the superior Lisp and return the result." @@ -1532,10 +1663,13 @@ (slime-dispatch-event `(:emacs-evaluate-oneway ,(prin1-to-string sexp) ,package))) +(defun slime-send (sexp) + (slime-net-send sexp slime-connection)) + (defun slime-sync () "Block until any asynchronous command has completed." (while (slime-busy-p) - (accept-process-output slime-net-process))) + (accept-process-output slime-connection))) (defun slime-busy-p () "Return true if Lisp is busy processing a request." @@ -1766,7 +1900,7 @@ (defun slime-repl-eval-string (string) (slime-eval-async `(swank:listener-eval ,string) - slime-lisp-package + (slime-lisp-package) (slime-repl-show-result-continutation))) (defun slime-repl-send-string (string) @@ -1983,7 +2117,7 @@ ("\C-j" 'slime-eval-print-last-expression)) -;;;; History +;;;;; History (defvar slime-repl-history-pattern nil "The regexp most recently used for finding input history.") @@ -2255,7 +2389,7 @@ (goto-char (next-overlay-change (point)))))) -;;;; Adding a single compiler note +;;;;; Adding a single compiler note (defun slime-overlay-note (note) "Add a compiler note to the buffer as an overlay. @@ -2484,7 +2618,7 @@ (defun slime-eval-feature-conditional (e) "Interpret a reader conditional expression." (if (symbolp e) - (member* (symbol-name e) slime-lisp-features :test #'equalp) + (member* (symbol-name e) (slime-lisp-features) :test #'equalp) (funcall (ecase (car e) (and #'every) (or #'some) @@ -2493,7 +2627,7 @@ (cdr e)))) -;;;; Visiting and navigating the overlays of compiler notes +;;;;; Visiting and navigating the overlays of compiler notes (defun slime-next-note () "Go to and describe the next compiler note in the buffer." @@ -2536,7 +2670,7 @@ (overlay-put overlay 'face 'slime-highlight-face))) -;;;; Overlay lookup operations +;;;;; Overlay lookup operations (defun slime-note-at-point () "Return the overlay for a note starting at point, otherwise NIL." @@ -2682,7 +2816,7 @@ documentation) -;;;; Asynchronous message idle timer +;;;;; Asynchronous message idle timer (defvar slime-autodoc-idle-timer nil "Idle timer for the next autodoc message.") @@ -2882,10 +3016,12 @@ If INITIAL-VALUE is non-nil, it is inserted into the minibuffer before reading input. The result is a string (\"\" if no input was given)." (let ((minibuffer-setup-hook - (cons (lexical-let ((package (slime-buffer-package))) - (lambda () - (setq slime-buffer-package package) - (set-syntax-table lisp-mode-syntax-table))) + (cons (lexical-let ((package (slime-buffer-package)) + (connection slime-connection)) + (lambda () + (setq slime-buffer-package package) + (set (make-local-variable 'slime-connection) connection) + (set-syntax-table lisp-mode-syntax-table))) minibuffer-setup-hook))) (read-from-minibuffer prompt initial-value slime-read-expression-map nil 'slime-read-expression-history))) @@ -3333,6 +3469,7 @@ ;;("p" 'slime-xref-previous) ) +;; FIXME: binding SLDB keys in xref buffer? -luke (dolist (spec slime-keys) (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec (when sldb @@ -3340,7 +3477,7 @@ (define-key slime-xref-mode-map key command))))) -;;;; XREF results buffer and window management +;;;;; XREF results buffer and window management (defun slime-xref-buffer () "Return the XREF results buffer. @@ -3413,7 +3550,7 @@ (skip-chars-forward " \t")))) -;;; XREF commands +;;;;; XREF commands (defun slime-who-calls (symbol) "Show all known callers of the function SYMBOL." @@ -3457,7 +3594,7 @@ (slime-show-xrefs result type symbol package))))) -;;;; XREF navigation +;;;;; XREF navigation (defun slime-xref-location-at-point () (or (get-text-property (point) 'slime-location) @@ -3620,13 +3757,7 @@ (message "package: %s default-directory: %s" package directory))) -;;; Debugger - -(defvar sldb-condition) -(defvar sldb-restarts) -(defvar sldb-level-in-buffer) -(defvar sldb-backtrace-start-marker) -(defvar sldb-mode-map) +;;; Debugger (SLDB) (defvar sldb-hook nil "Hook run on entry to the debugger.") @@ -3636,16 +3767,106 @@ string) (defmacro in-sldb-face (name string) + "Return STRING propertised with face sldb-NAME-face. +If `sldb-enable-styled-backtrace' is nil, just return STRING." (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) (var (gensym "string"))) `(let ((,var ,string)) (sldb-add-face ',facename ,var) ,var))) -(defun sldb-add-face (face string) - (if sldb-enable-styled-backtrace - (slime-add-face face string) - string)) + +;;;;; Local variables in the debugger buffer + +(make-variable-buffer-local + (defvar sldb-condition nil + "String describing the condition being debugged.")) + +(make-variable-buffer-local + (defvar sldb-restarts nil + "List of (NAME DESCRIPTION) for each available restart.")) + +(make-variable-buffer-local + (defvar sldb-level-in-buffer nil + "Current debug level (recursion depth) displayed in buffer.")) + +(make-variable-buffer-local + (defvar sldb-backtrace-start-marker nil + "Marker placed at the beginning of the backtrace text.")) + + +;;;;; sldb-mode + +(define-derived-mode sldb-mode fundamental-mode "sldb" + "Superior lisp debugger mode + +\\{sldb-mode-map}" + (erase-buffer) + (set-syntax-table lisp-mode-syntax-table) + (setq sldb-level-in-buffer (sldb-level)) + (setq mode-name (format "sldb[%d]" (sldb-level))) + (slime-set-truncate-lines) + ;; Make original `slime-connection' "sticky" for SLDB commands in this buffer + (make-local-variable 'slime-connection) + (add-hook (make-local-hook 'kill-buffer-hook) 'sldb-delete-overlays)) + +(slime-define-keys sldb-mode-map + ("v" 'sldb-show-source) + ((kbd "RET") 'sldb-default-action) + ("\C-m" 'sldb-default-action) + ([mouse-2] 'sldb-default-action/mouse) + ("e" 'sldb-eval-in-frame) + ("d" 'sldb-pprint-eval-in-frame) + ("D" 'sldb-disassemble) + ("i" 'sldb-inspect-in-frame) + ("n" 'sldb-down) + ("p" 'sldb-up) + ("\M-n" 'sldb-details-down) + ("\M-p" 'sldb-details-up) + ("l" 'sldb-list-locals) + ("t" 'sldb-toggle-details) + ("c" 'sldb-continue) + ("s" 'sldb-step) + ("a" 'sldb-abort) + ("q" 'sldb-quit) + ("B" 'sldb-break-with-default-debugger) + (":" 'slime-interactive-eval)) + +;; Inherit bindings from slime-mode +(dolist (spec slime-keys) + (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec + (when sldb + (let ((key (if prefixed (concat slime-prefix-key key) key))) + (define-key sldb-mode-map key command))))) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(defmacro define-sldb-invoke-restart-key (number key) + (let ((fname (intern (format "sldb-invoke-restart-%S" number)))) + `(progn + (defun ,fname () + (interactive) + (sldb-invoke-restart ,number)) + (define-key sldb-mode-map ,key ',fname)))) + +(defmacro define-sldb-invoke-restart-keys (from to) + `(progn + ,@(loop for n from from to to + collect `(define-sldb-invoke-restart-key ,n + ,(number-to-string n))))) + +(define-sldb-invoke-restart-keys 0 9) + + +;;;;; SLDB buffer creation & update + +(defvar sldb-overlays '() + "Overlays created in source code buffers to temporarily highlight expressions.") + +(defun get-sldb-buffer (&optional create) + (let* ((number (slime-connection-number)) + (buffer-name (format "*sldb [connection #%S]*" number))) + (funcall (if create #'get-buffer-create #'get-buffer) + buffer-name))) (defun sldb-insert-condition (condition) (destructuring-bind (message type) condition @@ -3670,35 +3891,43 @@ (insert "\n")) (defun sldb-setup (condition restarts frames) - (with-current-buffer (get-buffer-create "*sldb*") + "Setup a new SLDB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart. +FRAMES is a list (NUMBER DESCRIPTION) describing the initial +portion of the backtrace. Frames are numbered from 0." + (with-current-buffer (get-sldb-buffer t) (setq buffer-read-only nil) (sldb-mode) - (slime-set-truncate-lines) - (add-hook (make-local-variable 'kill-buffer-hook) 'sldb-delete-overlays) (setq sldb-condition condition) (setq sldb-restarts restarts) (sldb-insert-condition condition) (insert (in-sldb-face section "Restarts:") "\n") (sldb-insert-restarts restarts) - (insert (in-sldb-face section "Backtrace:") "\n") + (insert "\n" (in-sldb-face section "Backtrace:") "\n") (setq sldb-backtrace-start-marker (point-marker)) (sldb-insert-frames (sldb-prune-initial-frames frames) nil) (setq buffer-read-only t) (pop-to-buffer (current-buffer)) (run-hooks 'sldb-hook))) -(define-derived-mode sldb-mode fundamental-mode "sldb" - "Superior lisp debugger mode - -\\{sldb-mode-map}" - (erase-buffer) - (set-syntax-table lisp-mode-syntax-table) - (mapc #'make-local-variable '(sldb-condition - sldb-restarts - sldb-level-in-buffer - sldb-backtrace-start-marker)) - (setq sldb-level-in-buffer sldb-level) - (setq mode-name (format "sldb[%d]" sldb-level))) +(defun sldb-insert-restarts (restarts) + (loop for (name string) in restarts + for number from 0 + do (progn (slime-insert-propertized + `(restart-number ,number + sldb-default-action sldb-invoke-restart + mouse-face highlight) + " " + (in-sldb-face restart-number (number-to-string number)) + ": [" (in-sldb-face restart-type name) "] " + (in-sldb-face restart string)) + (insert "\n")))) + +(defun sldb-add-face (face string) + (if sldb-enable-styled-backtrace + (add-text-properties 0 (length string) (list 'face face) string) + string)) (defun sldb-prune-initial-frames (frames) "Return the prefix of FRAMES to initially present to the user. @@ -3718,6 +3947,8 @@ "\n"))) (defun sldb-insert-frames (frames maximum-length) + "Insert FRAMES into buffer. +MAXIMUM-LENGTH is the total number of frames in the Lisp stack." (when maximum-length (assert (<= (length frames) maximum-length))) (save-excursion @@ -3732,21 +3963,23 @@ sldb-previous-frame-number ,number) (in-sldb-face section " --more--\n"))))))) -(defun sldb-fetch-more-frames (&optional start end) +(defun sldb-fetch-more-frames (&rest ignore) + "Fetch more backtrace frames. +Called on the `point-entered' text-property hook." (let ((inhibit-point-motion-hooks t)) (let ((inhibit-read-only t)) - (let ((previous (get-text-property (point) - 'sldb-previous-frame-number))) - (when previous - (beginning-of-line) - (let ((start (point))) - (end-of-buffer) - (delete-region start (point))) - (let ((start (1+ previous)) - (end (+ previous 40))) - (sldb-insert-frames - (slime-eval `(swank:backtrace ,start ,end)) - (- end start)))))))) + (when-let (previous (get-text-property (point) 'sldb-previous-frame-number)) + (beginning-of-line) + (let ((start (point))) + (end-of-buffer) + (delete-region start (point))) + (let ((start (1+ previous)) + (end (+ previous 40))) + (sldb-insert-frames (slime-eval `(swank:backtrace ,start ,end)) + (- end start))))))) + + +;;;;; SLDB commands (defun sldb-default-action/mouse (event) (interactive "e") @@ -3761,8 +3994,6 @@ (let ((fn (get-text-property (point) 'sldb-default-action))) (if fn (funcall fn)))) -(defvar sldb-overlays '()) - (defun sldb-delete-overlays () (mapc #'delete-overlay sldb-overlays) (setq sldb-overlays '())) @@ -3786,8 +4017,9 @@ (save-excursion (sldb-backward-frame) (sldb-frame-number-at-point))) - + (defun sldb-show-source () + "Highlight the frame at point's expression in a source code buffer." (interactive) (sldb-delete-overlays) (let* ((number (sldb-frame-number-at-point))) @@ -3806,11 +4038,10 @@ (beginning-of-line -4) (set-window-start (get-buffer-window (current-buffer) t) (point))))) -(defun sldb-frame-details-visible-p () - (and (get-text-property (point) 'frame) - (get-text-property (point) 'details-visible-p))) - + (defun sldb-toggle-details (&optional on) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." (interactive) (sldb-frame-number-at-point) (let ((inhibit-read-only t)) @@ -3818,12 +4049,9 @@ (sldb-show-frame-details) (sldb-hide-frame-details)))) -(defun sldb-frame-region () - (save-excursion - (goto-char (next-single-property-change (point) 'frame nil (point-max))) - (backward-char) - (values (previous-single-property-change (point) 'frame) - (next-single-property-change (point) 'frame nil (point-max))))) +(defun sldb-frame-details-visible-p () + (and (get-text-property (point) 'frame) + (get-text-property (point) 'details-visible-p))) (defun sldb-show-frame-details () (multiple-value-bind (start end) (sldb-frame-region) @@ -3859,6 +4087,13 @@ (point))))) (apply #'sldb-maybe-recenter-region (sldb-frame-region))) +(defun sldb-frame-region () + (save-excursion + (goto-char (next-single-property-change (point) 'frame nil (point-max))) + (backward-char) + (values (previous-single-property-change (point) 'frame) + (next-single-property-change (point) 'frame nil (point-max))))) + (defun sldb-maybe-recenter-region (start end) (sit-for 0 nil) (cond ((and (< (window-start) start) @@ -3879,6 +4114,7 @@ (slime-propertize-region (plist-put props 'details-visible-p nil) (sldb-insert-frame frame)))))) + (defun sldb-eval-in-frame (string) (interactive (list (slime-read-from-minibuffer "Eval in frame: "))) (let* ((number (sldb-frame-number-at-point))) @@ -3970,14 +4206,14 @@ (slime-message "%S" (sldb-catch-tags (sldb-frame-number-at-point)))) (defun sldb-cleanup () - (let ((sldb-buffer (get-buffer "*sldb*"))) - (when sldb-buffer - (if (> sldb-level 1) - (with-current-buffer sldb-buffer - (let ((inhibit-read-only t)) - (erase-buffer))) - (kill-buffer sldb-buffer))))) + (when-let (sldb-buffer (get-sldb-buffer)) + (if (> (sldb-level) 1) + (with-current-buffer sldb-buffer + (let ((inhibit-read-only t)) + (erase-buffer))) + (kill-buffer sldb-buffer)))) + (defun sldb-quit () (interactive) (slime-eval-async '(swank:throw-to-toplevel) nil (lambda (_)))) @@ -3998,15 +4234,13 @@ (defun sldb-invoke-restart (&optional number) (interactive) - (let ((restart (or number - (sldb-restart-at-point) - (error "No restart at point")))) - (slime-eval-async - `(swank:invoke-nth-restart-for-emacs ,sldb-level ,restart) nil - (lambda (_))))) + (let ((restart (or number (sldb-restart-at-point)))) + (slime-oneway-eval `(swank:invoke-nth-restart-for-emacs ,(sldb-level) ,restart) + nil))) (defun sldb-restart-at-point () - (get-text-property (point) 'restart-number)) + (or (get-text-property (point) 'restart-number) + (error "No restart at point"))) (defun sldb-break-with-default-debugger () (interactive) @@ -4018,60 +4252,7 @@ (interactive) (let ((frame (sldb-frame-number-at-point))) (slime-eval-async `(swank:sldb-step ,frame) nil (lambda ())))) - -(defun sldb-disassemble () - "Disassemble the code for the current frame." - (interactive) - (let ((frame (sldb-frame-number-at-point))) - (slime-eval-async `(swank:sldb-disassemble ,frame) nil - (lambda (result) - (slime-show-description result nil))))) -(slime-define-keys sldb-mode-map - ("v" 'sldb-show-source) - ((kbd "RET") 'sldb-default-action) - ("\C-m" 'sldb-default-action) - ([mouse-2] 'sldb-default-action/mouse) - ("e" 'sldb-eval-in-frame) - ("d" 'sldb-pprint-eval-in-frame) - ("D" 'sldb-disassemble) - ("i" 'sldb-inspect-in-frame) - ("n" 'sldb-down) - ("p" 'sldb-up) - ("\M-n" 'sldb-details-down) - ("\M-p" 'sldb-details-up) - ("l" 'sldb-list-locals) - ("t" 'sldb-toggle-details) - ("c" 'sldb-continue) - ("s" 'sldb-step) - ("a" 'sldb-abort) - ("q" 'sldb-quit) - ("B" 'sldb-break-with-default-debugger) - (":" 'slime-interactive-eval)) - -(dolist (spec slime-keys) - (destructuring-bind (key command &key sldb prefixed &allow-other-keys) spec - (when sldb - (let ((key (if prefixed (concat slime-prefix-key key) key))) - (define-key sldb-mode-map key command))))) - -;; Keys 0-9 are shortcuts to invoke particular restarts. -(defmacro define-sldb-invoke-restart-key (number key) - (let ((fname (intern (format "sldb-invoke-restart-%S" number)))) - `(progn - (defun ,fname () - (interactive) - (sldb-invoke-restart ,number)) - (define-key sldb-mode-map ,key ',fname)))) - -(defmacro define-sldb-invoke-restart-keys (from to) - `(progn - ,@(loop for n from from to to - collect `(define-sldb-invoke-restart-key ,n - ,(number-to-string n))))) - -(define-sldb-invoke-restart-keys 0 9) - ;;; Thread control panel @@ -4124,7 +4305,8 @@ (remove* id slime-waiting-threads :key #'car :test #'equal)) (slime-thread-control-panel t))) -;;;; Major mode + +;;;;; Major mode (define-derived-mode slime-thread-control-mode fundamental-mode "thread-control" @@ -4244,7 +4426,7 @@ ("q" 'slime-inspector-quit)) -;;; `Select' +;;; Buffer selector (defvar slime-selector-methods nil "List of buffer-selection methods for the `slime-select' command. @@ -4320,10 +4502,10 @@ (slime-recently-visited-buffer 'lisp-mode)) (def-slime-selector-method ?d - "the *sldb* buffer buffer" - (unless (get-buffer "*sldb*") + "the *sldb* buffer for the current connection." + (unless (get-sldb-buffer) (error "No debugger buffer")) - "*sldb*") + (get-sldb-buffer)) (def-slime-selector-method ?e "the most recently visited emacs-lisp-mode buffer." @@ -4357,7 +4539,7 @@ "The name of the buffer used to display test results.") -;;;; Execution engine +;;;;; Execution engine (defun slime-run-tests () "Run the test suite. @@ -4388,10 +4570,17 @@ (dolist (input inputs) (incf slime-total-tests) (slime-test-heading 2 "input: %s" input) - (condition-case err - (apply function input) - (error (incf slime-failed-tests) - (slime-print-check-error err)))))) + (if slime-test-debug-on-error + (let ((debug-on-error t) + (debug-on-quit t)) + (apply function input)) + (condition-case err + (apply function input) + (error + (when slime-test-debug-on-error + (debug (format "Error in test: %S" err))) + (incf slime-failed-tests) + (slime-print-check-error err))))))) (let ((summary (if (zerop slime-failed-tests) (format "All %S tests completed successfully." slime-total-tests) @@ -4423,7 +4612,7 @@ (kill-emacs failed-tests)))) -;;;; Results buffer creation and output +;;;;; Results buffer creation and output (defun slime-create-test-results-buffer () "Create and initialize the buffer for test suite results." @@ -4472,7 +4661,7 @@ (insert string "\n"))) -;;;; Macros for defining test cases +;;;;; Macros for defining test cases (defmacro def-slime-test (name args doc inputs &rest body) "Define a test case. @@ -4520,7 +4709,7 @@ (put 'slime-check 'lisp-indent-function 1) -;;;; Test case definitions +;;;;; Test case definitions ;; Clear out old tests. (setq slime-tests nil) @@ -4616,18 +4805,18 @@ (debug-hook-max-depth 0)) (let ((debug-hook (lambda () - (when (> sldb-level debug-hook-max-depth) - (setq debug-hook-max-depth sldb-level) + (when (> (sldb-level) debug-hook-max-depth) + (setq debug-hook-max-depth (sldb-level)) (slime-check - ("Automaton stack reflects debug level %S." sldb-level) + ("Automaton stack reflects debug level %S." (sldb-level)) ;; Inspect the stack to ensure we are debugging at the ;; expected recursion depth. (let ((expected-stack '(slime-idle-state))) - (dotimes (i sldb-level) + (dotimes (i (sldb-level)) (push 'slime-evaluating-state expected-stack) (push 'slime-debugging-state expected-stack)) (slime-test-state-stack expected-stack))) - (if (= sldb-level depth) + (if (= (sldb-level) depth) ;; We're at maximum recursion - time to unwind (sldb-quit) ;; Going down - enter another recursive debug @@ -4641,16 +4830,13 @@ (slime-check ("Maximum depth reached (%S) is %S." debug-hook-max-depth depth) (= debug-hook-max-depth depth)) - ;; FIXME: synchronize properly somehow. We are expecting Lisp - ;; to perform a restart and unwind our stack. and the restart - ;; should have put us back at the top level. (slime-sync-state-stack '(slime-idle-state) 5) (slime-check "Automaton is back in idle state." (slime-test-state-stack '(slime-idle-state))))))) (defun slime-test-state-stack (states) "True if STATES describes the current stack of states." - (equal states (mapcar #'slime-state-name slime-state-stack))) + (equal states (mapcar #'slime-state-name (slime-state-stack)))) (defun slime-sync-state-stack (state-stack timeout) "Wait until the machine's stack is STATE-STACK or the timeout \ @@ -4673,7 +4859,7 @@ (and (slime-test-state-stack '(slime-debugging-state slime-evaluating-state slime-idle-state)) - (get-buffer "*sldb*"))) + (get-sldb-buffer))) (sldb-quit)))) (accept-process-output nil 1) (slime-check "In eval state." @@ -4696,14 +4882,14 @@ (and (slime-test-state-stack '(slime-debugging-state slime-evaluating-state slime-idle-state)) - (get-buffer "*sldb*"))) + (get-sldb-buffer))) (let ((slime-evaluating-state-activation-hook (lambda () (when (slime-test-state-stack '(slime-evaluating-state slime-idle-state)) (setq slime-evaluating-state-activation-hook nil) (slime-check "No sldb buffer." - (not (get-buffer "*sldb*"))) + (not (get-sldb-buffer))) (let ((sldb-hook (lambda () (slime-check "Second interrupt." @@ -4711,7 +4897,7 @@ '(slime-debugging-state slime-evaluating-state slime-idle-state)) - (get-buffer "*sldb*"))) + (get-sldb-buffer))) (sldb-quit)))) (accept-process-output nil 1) (slime-check "In eval state." @@ -4758,7 +4944,7 @@ (and (slime-test-state-stack '(slime-debugging-state slime-evaluating-state slime-idle-state)) - (get-buffer "*sldb*"))) + (get-sldb-buffer))) (sldb-quit)))) (accept-process-output nil 1) (slime-check "In eval state." @@ -4964,7 +5150,8 @@ slime-output-string slime-output-buffer slime-with-output-end-mark - slime-process-available-input + ;; Compilation warns due to runtime call to a `cl' function. Annoying. +;; slime-process-available-input slime-dispatch-event slime-net-filter slime-net-have-input-p From heller at common-lisp.net Tue Jan 6 13:10:29 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 06 Jan 2004 08:10:29 -0500 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26407 Modified Files: swank-loader.lisp Log Message: (user-init-file): Use mergepathame. Fix Windows support. Patch by Ignas Mikalajunas . Date: Tue Jan 6 08:10:29 2004 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.11 slime/swank-loader.lisp:1.12 --- slime/swank-loader.lisp:1.11 Fri Jan 2 03:16:46 2004 +++ slime/swank-loader.lisp Tue Jan 6 08:10:29 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.11 2004/01/02 08:16:46 heller Exp $ +;;; $Id: swank-loader.lisp,v 1.12 2004/01/06 13:10:29 heller Exp $ ;;; (cl:defpackage :swank-loader @@ -65,12 +65,10 @@ (defun user-init-file () "Return the name of the user init file or nil." - (let ((home (user-homedir-pathname))) - (and (probe-file home) - (probe-file (format nil - #-mswindows "~A/.swank.lisp" - #+mswindows "~A\\_swank.lsp" - (namestring (truename home))))))) + (probe-file + (merge-pathnames (user-homedir-pathname) + #-mswindows (make-pathname :name ".swank" :type "lisp") + #+mswindows (make-pathname :name "_swank" :type "lsp")))) (compile-files-if-needed-serially (list* (make-swank-pathname "swank-backend") *swank-pathname* From heller at common-lisp.net Tue Jan 6 13:40:07 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 06 Jan 2004 08:40:07 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3836 Modified Files: slime.el Log Message: (slime-connect): Select the new connection. (slime-init-connection): New optinal argument SELECT. (slime-def-connection-var): Workarounds for Emacs 20 reader bugs. Backquote is pretty broken Emacs 20. The new macro 'slime-rex' can now be used to evaluate sexp remotely. slime-rex provides finer control what to do when the evaluation aborts. slime-eval and slime-eval-async are now implemented with slime-rex. (slime-rex): New macro (slime-eval, slime-eval-async): Use it. (slime-continuation-counter, slime-push-evaluating-state): New functions. (slime-output-buffer): Initialize markers. (sldb-mode): XEmacs doesn't like (add-hook (make-local-hook ...)). (sldb-continue, sldb-invoke-restart): Use slime-rex. Date: Tue Jan 6 08:40:06 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.161 slime/slime.el:1.162 --- slime/slime.el:1.161 Mon Jan 5 15:51:44 2004 +++ slime/slime.el Tue Jan 6 08:40:05 2004 @@ -954,7 +954,7 @@ (y-or-n-p "Close old connections first? ")))) (when kill-old-p (slime-disconnect)) (message "Connecting to Swank on port %S.." port) - (slime-init-connection (slime-net-connect "localhost" port)) + (slime-init-connection (slime-net-connect "localhost" port) t) (when-let (buffer (get-buffer "*inferior-lisp*")) (delete-windows-on buffer) (bury-buffer buffer)) @@ -1194,9 +1194,9 @@ ;; Setf (defsetf ,varname () (store) `(slime-with-connection-buffer () - (setq ,',real-var ,store) - ,store)) - ',varname))) + (setq (\, (quote (\, real-var))) (\, store)) + (\, store))) + '(\, varname)))) (slime-def-connection-var slime-lisp-features '() "The symbol-names of Lisp's *FEATURES*. @@ -1286,12 +1286,12 @@ (slime-with-connection-buffer () slime-state-stack)) -(defun slime-init-connection (proc) +(defun slime-init-connection (proc &optional select) "Initialize the stack machine." (let ((slime-connection proc)) (slime-init-connection-state) (sldb-cleanup)) - (when (null slime-connection) + (when (or select (null slime-connection)) (slime-select-connection proc))) (defun slime-init-connection-state () @@ -1491,9 +1491,6 @@ ;;;;; The SLIME state machine definition -(defvar slime-stack-eval-tags nil - "List of stack-tags of continuations waiting on the stack.") - (slime-defstate slime-idle-state () "Idle state. The user may make a request, or Lisp may invoke the debugger." ((activate) @@ -1503,38 +1500,24 @@ (slime-push-state (slime-debugging-state level condition restarts frames (current-window-configuration)))) - ((:emacs-evaluate form-string package-name continuation) - (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-rex form-string package-name continuation) + (slime-push-evaluating-state form-string package-name continuation)) ((:emacs-evaluate-oneway form-string package-name) (slime-output-oneway-evaluate-request form-string package-name))) (defvar slime-evaluating-state-activation-hook nil "Hook called when the evaluating state is actived.") -(slime-defstate slime-evaluating-state (continuation) +(slime-defstate slime-evaluating-state (saved-id continuation) "Evaluting state. We have asked Lisp to evaluate a form, and when the result arrives we will pass it to CONTINUATION." ((activate) (run-hooks 'slime-evaluating-state-activation-hook)) - ((:ok result) + ((:return result id) + (assert (= id saved-id) nil "Continuation mismatch: %s %s" id saved-id) (slime-pop-state) - (destructure-case continuation - ((:function f) - (funcall f result)) - ((:catch-tag tag) - (when (member tag slime-stack-eval-tags) - (throw tag `(:ok ,result)))))) - ((:aborted) - (destructure-case continuation - ((:function f) - (message "Evaluation aborted.") - (slime-pop-state)) - ((:catch-tag tag) - (slime-pop-state) - (when (member tag slime-stack-eval-tags) - (throw tag `(:aborted)))))) + (funcall continuation result)) ((:debug level condition restarts frames) (slime-push-state (slime-debugging-state level condition restarts frames @@ -1567,10 +1550,8 @@ (decf (sldb-level)) (set-window-configuration saved-window-configuration) (slime-pop-state)) - ((:emacs-evaluate form-string package-name continuation) - ;; recursive evaluation request - (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-rex form-string package-name continuation) + (slime-push-evaluating-state form-string package-name continuation)) ((:emacs-evaluate-oneway form-string package-name) (slime-output-oneway-evaluate-request form-string package-name))) @@ -1582,9 +1563,8 @@ ((:emacs-return-string code) (slime-net-send `(swank:take-input ,tag ,code) slime-connection) (slime-pop-state)) - ((:emacs-evaluate form-string package-name continuation) - (slime-output-evaluate-request form-string package-name) - (slime-push-state (slime-evaluating-state continuation))) + ((:emacs-rex form-string package-name continuation) + (slime-push-evaluating-state form-string package-name continuation)) ((:emacs-evaluate-oneway form-string package-name) (slime-output-oneway-evaluate-request form-string package-name)) ((:read-aborted) @@ -1594,10 +1574,6 @@ ;;;;; Utilities -(defun slime-output-evaluate-request (form-string package-name) - "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." - (slime-send `(swank:eval-string ,form-string ,package-name))) - (defun slime-output-oneway-evaluate-request (form-string package-name) "Like `slime-output-oneway-evaluate-request' but without expecting a result." (slime-send `(swank:oneway-eval-string ,form-string ,package-name))) @@ -1610,11 +1586,6 @@ "Return true if the Swank connection is open." (not (null slime-net-processes))) -(defun slime-eval-string-async (string package continuation) - (when (slime-busy-p) - (error "Lisp is already busy evaluating a request.")) - (slime-dispatch-event `(:emacs-evaluate ,string ,package ,continuation))) - (defconst +slime-sigint+ 2) (defun slime-send-sigint () @@ -1623,37 +1594,84 @@ ;;;;; Emacs Lisp programming interface +(defvar slime-continuation-counter 0) + +(defun slime-push-evaluating-state (form-string package-name continuation) + "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME." + (slime-push-state (slime-evaluating-state (incf slime-continuation-counter) + continuation)) + (slime-send `(swank:eval-string ,form-string ,package-name + ,slime-continuation-counter))) + +(defmacro* slime-rex ((&rest saved-vars) + (sexp &optional (package 'slime-buffer-package)) + &rest continuations) + "(slime-rex (VAR ...) (SEXP [PACKAGE]) CLAUSES ...) + +Remote EXecute SEXP. + +VARs are a list of saved variables visible in the other forms. Each +VAR is either a symbol or a list (VAR INIT-VALUE). + +SEXP is evaluated and the princed version is sent to Lisp. + +PACKAGE is evaluated and Lisp reads the princed form in this package. +The default value is `slime-buffer-package'. + +CLAUSES is a list of patterns with same syntax as `destructure-case'. +The result of the evaluation is dispatched on CLAUSES. The result is +either a sexp of the form (:ok VALUE) or (:abort). CLAUSES is +executed asynchronously. + +Note: don't use backquote syntax for SEXP, because Emacs20 cannot +deal with that." + (let ((result (gensym))) + `(lexical-let ,(loop for var in saved-vars + collect (etypecase var + (symbol (list var var)) + (cons var))) + (when (slime-busy-p) + (error "Lisp is already busy evaluating a request.")) + (slime-dispatch-event (list :emacs-rex (prin1-to-string ,sexp) ,package + (lambda (,result) + (destructure-case ,result + , at continuations))))))) + +(put 'slime-rex 'lisp-indent-function 2) + +(defvar slime-stack-eval-tags nil + "List of stack-tags of continuations waiting on the stack.") + (defun slime-eval (sexp &optional package) "Evaluate EXPR on the superior Lisp and return the result." - (slime-check-connected) (let* ((tag (gensym "slime-result-")) (slime-stack-eval-tags (cons tag slime-stack-eval-tags))) - (destructure-case - (catch tag (slime-do-eval sexp package `(:catch-tag ,tag))) - ((:ok value) - value) - ((:aborted) - (error "Lisp Evaluation aborted."))))) - -(defun slime-do-eval (sexp package continuation) - "Perform an evaluation synchronously. -Loops until the result is thrown to our caller, or the user aborts." - (slime-eval-string-async (prin1-to-string sexp) package continuation) - (let ((debug-on-quit t) - (inhibit-quit nil)) - (while (slime-busy-p) - (accept-process-output))) - ;; No longer busy, but result not delivered. That means we have - ;; entered the debugger. - (recursive-edit) - ;; If we get here, the user completed the recursive edit without - ;; coaxing the debugger into returning. We abort. - (error "Evaluation aborted.")) + (catch tag + (slime-rex (tag) + (sexp package) + ((:ok value) + (assert (member tag slime-stack-eval-tags)) + (throw tag value)) + ((:abort) + (error "Lisp Evaluation aborted."))) + (let ((debug-on-quit t) + (inhibit-quit nil)) + (while t + (accept-process-output nil 0 10000) + (when (slime-debugging-p) + (recursive-edit) + ;; If we get here, the user completed the recursive edit without + ;; coaxing the debugger into returning. We abort. + (error "Evaluation aborted."))))))) (defun slime-eval-async (sexp package cont) "Evaluate EXPR on the superior Lisp and call CONT with the result." - (slime-check-connected) - (slime-eval-string-async (prin1-to-string sexp) package `(:function ,cont))) + (slime-rex (cont) + (sexp package) + ((:ok result) + (funcall cont result)) + ((:abort) + (message "Evaluation aborted.")))) (defun slime-oneway-eval (sexp &optional package) "Evaluate SEXP \"one-way\" - without receiving a return value." @@ -1711,6 +1729,13 @@ "Return the output buffer, create it if necessary." (or (get-buffer "*slime-repl*") (with-current-buffer (get-buffer-create "*slime-repl*") + (dolist (mark (list slime-output-start + slime-output-end + slime-repl-prompt-start-mark + slime-repl-input-start-mark + slime-repl-input-end-mark + slime-repl-last-input-start-mark)) + (set-marker mark (point))) (slime-repl-mode) (slime-repl-insert-prompt) (current-buffer)))) @@ -3808,7 +3833,8 @@ (slime-set-truncate-lines) ;; Make original `slime-connection' "sticky" for SLDB commands in this buffer (make-local-variable 'slime-connection) - (add-hook (make-local-hook 'kill-buffer-hook) 'sldb-delete-overlays)) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'sldb-delete-overlays)) (slime-define-keys sldb-mode-map ("v" 'sldb-show-source) @@ -4220,13 +4246,12 @@ (defun sldb-continue () (interactive) - (slime-eval-async - '(swank:sldb-can-continue-p) nil - (lambda (answer) - (cond (answer - (slime-oneway-eval '(swank::sldb-continue) nil)) - (t - (message "No restart named continue") (ding)))))) + (slime-rex () + ('(swank::sldb-continue)) + ((:ok _) + (message "No restart named continue") + (ding)) + ((:abort) ))) (defun sldb-abort () (interactive) @@ -4235,8 +4260,10 @@ (defun sldb-invoke-restart (&optional number) (interactive) (let ((restart (or number (sldb-restart-at-point)))) - (slime-oneway-eval `(swank:invoke-nth-restart-for-emacs ,(sldb-level) ,restart) - nil))) + (slime-rex () + ((list 'swank:invoke-nth-restart-for-emacs (sldb-level) restart)) + ((:ok value) (message "Restart returned: %s" value)) + ((:abort))))) (defun sldb-restart-at-point () (or (get-text-property (point) 'restart-number) From heller at common-lisp.net Tue Jan 6 13:42:22 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 06 Jan 2004 08:42:22 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12832 Modified Files: swank.lisp Log Message: (eval-string): New argument 'id'. Used to identify the remote continuation. (log-event): New debugging function. (read-from-emacs, send-to-emacs): Use it. Date: Tue Jan 6 08:42:22 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.86 slime/swank.lisp:1.87 --- slime/swank.lisp:1.86 Fri Jan 2 13:20:53 2004 +++ slime/swank.lisp Tue Jan 6 08:42:22 2004 @@ -145,9 +145,18 @@ (apply fn args)) (apply fn args))) +(defvar *log-events* nil) + +(defun log-event (format-string &rest args) + "Write a message to *terminal-io* when *log-events* is non-nil. +Useful for low level debugging." + (when *log-events* + (apply #'format *terminal-io* format-string args))) + (defun read-from-emacs () "Read and process a request from Emacs." (let ((form (read-next-form))) + (log-event "READ: ~S~%" form) (call-with-slime-streams *slime-input* *slime-output* *slime-io* #'funcall form))) @@ -194,6 +203,7 @@ "Send `object' to Emacs." (let* ((string (prin1-to-string-for-emacs object)) (length (1+ (length string)))) + (log-event "SEND: ~A~%" string) (with-I/O-lock (without-interrupts* (lambda () @@ -425,7 +435,7 @@ (swank::send-to-emacs `(:%apply ,(string-downcase (string fn)) ,args)))) -(defslimefun eval-string (string buffer-package) +(defslimefun eval-string (string buffer-package id) (let ((*processing-rpc* t) (*debugger-hook* #'swank-debugger-hook)) (let (ok result) @@ -437,7 +447,7 @@ (setq ok t)) (sync-state-to-emacs) (force-output *slime-io*) - (send-to-emacs (if ok `(:ok ,result) '(:aborted)))))) + (send-to-emacs `(:return ,(if ok `(:ok ,result) '(:abort)) ,id))))) (when *debugger-hook-passback* (setq *debugger-hook* *debugger-hook-passback*) (setq *debugger-hook-passback* nil))) From heller at common-lisp.net Tue Jan 6 13:50:19 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 06 Jan 2004 08:50:19 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22309 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jan 6 08:50:17 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.184 slime/ChangeLog:1.185 --- slime/ChangeLog:1.184 Mon Jan 5 15:51:50 2004 +++ slime/ChangeLog Tue Jan 6 08:50:16 2004 @@ -1,3 +1,29 @@ +2004-01-06 Helmut Eller + + * swank.lisp (eval-string): New argument 'id'. Used to identify + the remote continuation. + (log-event): New debugging function. + (read-from-emacs, send-to-emacs): Use it. + + * slime.el: The new macro 'slime-rex' can now be used to evaluate + sexps remotely. It offers finer control what to do when the + evaluation aborts. + (slime-rex): New macro + (slime-eval, slime-eval-async, sldb-continue) + (sldb-invoke-restart): Use it. + (slime-continuation-counter, slime-push-evaluating-state): New + functions. + (slime-output-buffer): Initialize markers. + (sldb-mode): XEmacs doesn't like (add-hook (make-local-hook ...)). + (slime-init-connection): New optional argument SELECT. + (slime-def-connection-var): Workarounds for Emacs 20 reader bugs. + Backquote is pretty broken Emacs 20. + +2004-01-06 Ignas Mikalajunas + + * swank-loader.lisp (user-init-file): Use merge-pathames. Fix + Windows support. + 2004-01-05 Luke Gorrie * slime.el: Multiple session support, i.e. Emacs can open @@ -138,7 +164,6 @@ (slime-open-inspector): Minor indentation fixes. (slime-net-output-funcall): Removed. Was unused. ->>>>>>> 1.183 2003-12-19 Alan Ruttenberg * slime.el 1.157 fix bug in sldb-princ-locals I introduced when adding fonts to sldb From lgorrie at common-lisp.net Wed Jan 7 00:12:02 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 06 Jan 2004 19:12:02 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8139 Modified Files: slime.el Log Message: (slime): Multisession support: with prefix argument, gives the option of keeping existing sessions and firing up an additional *inferior-lisp* to connect to. Each connection now has its own *slime-repl[]* buffer. (slime-connection): Should now be read via the function of the same name. The accessor will check if the value is NIL, and if so use `slime-default-connection'. (slime-default-connection): The connection that will be used by default, i.e. unless `slime-connection' is bound. Renamed from `slime-primary-connection'. (slime-init-connection-state): When reconnecting, update the `slime-connection' binding in the REPL to use the new connection. (slime-repl-input-history, ...): REPL variables are now buffer-local. Date: Tue Jan 6 19:12:02 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.162 slime/slime.el:1.163 --- slime/slime.el:1.162 Tue Jan 6 08:40:05 2004 +++ slime/slime.el Tue Jan 6 19:12:02 2004 @@ -801,7 +801,7 @@ `slime-connection' in a buffer-local variable." (let ((config (gensym))) `(let ((,config (current-window-configuration)) - (connection slime-connection) + (connection (slime-connection)) (standard-output (with-current-buffer (get-buffer-create ,name) (setq buffer-read-only nil) (erase-buffer) @@ -871,8 +871,15 @@ (defun slime () "Start an inferior^_superior Lisp and connect to its Swank server." (interactive) - (when (slime-connected-p) - (slime-disconnect)) + (if (and current-prefix-arg + (slime-connected-p) + (get-buffer-create "*inferior-lisp*")) + (if (y-or-n-p "Start additional *inferior-lisp* for connection? ") + ;; Rename old inferior-lisp buffer out of the way + (let ((bufname (generate-new-buffer-name "*inferior-lisp*"))) + (with-current-buffer "*inferior-lisp*" + (rename-buffer bufname))) + (slime-disconnect))) (slime-maybe-start-lisp) (slime-maybe-start-multiprocessing) (slime-read-port-and-connect)) @@ -1037,7 +1044,7 @@ (defun slime-net-sentinel (process message) (when (ignore-errors (eq (process-status (inferior-lisp-proc)) 'open)) (message "Lisp connection closed unexpectedly: %s" message)) - (when (eq process slime-primary-connection) + (when (eq process slime-default-connection) (setq slime-state-name "[not connected]")) (force-mode-line-update) (slime-net-close process)) @@ -1107,11 +1114,13 @@ commands. Can be bound dynamically to use a particular connection temporarily. - Can be bound buffer-locally to make a particular connection -\"sticky\" for commands in a particular buffer.") +\"sticky\" for commands in a particular buffer. + +You should not read this variable directly. Use the function of +the same name instead.") -(defvar slime-primary-connection nil +(defvar slime-default-connection nil "Network process selected for top-level use. This variable is only used to test whether some process is the primary process.") @@ -1124,33 +1133,43 @@ "Serial number of a connection. Bound in the connection's process-buffer.")) +(defun slime-connection () + "Return the current connection." + (when (and slime-connection + (not (eq (process-status slime-connection) 'open))) + (if (and slime-default-connection + (y-or-n-p "Buffer's connection closed; switch to default? ")) + (setq slime-connection nil) + (error "Buffer's connection closed."))) + (or slime-connection + slime-default-connection + (error "No connection."))) + (defun slime-connection-number (&optional connection) (slime-with-connection-buffer (connection) slime-connection-number)) (defvar slime-state-name "[??]" - "Name of the current state of `slime-primary-connection'. + "Name of the current state of `slime-default-connection'. For display in the mode-line.") (defmacro* slime-with-connection-buffer ((&optional process) &rest body) "Execute BODY in the process-buffer of PROCESS. If PROCESS is not specified, `slime-connection' is used." `(with-current-buffer - (process-buffer (or ,process slime-connection (error "No connection"))) + (process-buffer (or ,process (slime-connection) (error "No connection"))) , at body)) (defun slime-select-connection (process) - (setq slime-connection process) - (setq slime-primary-connection process) - (let ((message (format "Selected connection: %S" (slime-connection-number)))) - (unless (get-buffer-window (slime-output-buffer) t) - (message message)))) + (setq slime-default-connection process) + (unless (get-buffer-window (slime-output-buffer) t) + (message (format "Selected connection: %S" (slime-connection-number))))) (defun slime-connection-close-hook (process) (when (eq process slime-connection) (setq slime-connection nil)) - (when (eq process slime-primary-connection) - (setq slime-primary-connection nil))) + (when (eq process slime-default-connection) + (setq slime-default-connection nil))) (add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) @@ -1160,7 +1179,7 @@ (interactive) (when (null slime-net-processes) (error "Not connected.")) - (let ((conn (nth (mod (1+ (or (position slime-connection slime-net-processes) 0)) + (let ((conn (nth (mod (1+ (or (position (slime-connection) slime-net-processes) 0)) (length slime-net-processes)) slime-net-processes))) (slime-select-connection conn))) @@ -1290,14 +1309,23 @@ "Initialize the stack machine." (let ((slime-connection proc)) (slime-init-connection-state) - (sldb-cleanup)) - (when (or select (null slime-connection)) - (slime-select-connection proc))) + (when (or select (null slime-default-connection)) + (slime-select-connection proc)) + (sldb-cleanup))) (defun slime-init-connection-state () + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal slime-net-processes (list slime-connection)) + (setq slime-connection-counter 0)) (slime-with-connection-buffer () (setq slime-state-stack (list (slime-idle-state))) (setq slime-connection-number (incf slime-connection-counter))) + (when-let (repl-buffer (slime-repl-buffer)) + ;; REPL buffer already exists - update its local + ;; `slime-connection' binding. + (with-current-buffer repl-buffer + (setq slime-connection proc))) (setf (slime-pid) (slime-eval '(swank:getpid))) (when slime-global-debugger-hook (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER")) @@ -1312,7 +1340,7 @@ (slime-dispatch-event '(activate)))) (defun slime-update-state-name () - (slime-with-connection-buffer (slime-primary-connection) + (slime-with-connection-buffer (slime-default-connection) (setq slime-state-name (ecase (slime-state-name state) (slime-idle-state "") @@ -1341,7 +1369,7 @@ "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going into the state machine." - (let ((slime-connection (or process slime-connection))) + (let ((slime-connection (or process (slime-connection)))) (slime-log-event event) (unless (slime-handle-oob event) (funcall (slime-state-function (slime-current-state)) event)))) @@ -1475,7 +1503,7 @@ (t ;; Illegal event for current state. This is a BUG! (slime-state/event-panic ,event-var - slime-connection)))))))) + (slime-connection))))))))) (defmacro slime-defstate (name variables doc &rest events) "Define a state called NAME and comprised of VARIABLES. @@ -1561,7 +1589,7 @@ ((activate) (slime-repl-read-string)) ((:emacs-return-string code) - (slime-net-send `(swank:take-input ,tag ,code) slime-connection) + (slime-net-send `(swank:take-input ,tag ,code) (slime-connection)) (slime-pop-state)) ((:emacs-rex form-string package-name continuation) (slime-push-evaluating-state form-string package-name continuation)) @@ -1682,12 +1710,12 @@ `(:emacs-evaluate-oneway ,(prin1-to-string sexp) ,package))) (defun slime-send (sexp) - (slime-net-send sexp slime-connection)) + (slime-net-send sexp (slime-connection))) (defun slime-sync () "Block until any asynchronous command has completed." (while (slime-busy-p) - (accept-process-output slime-connection))) + (accept-process-output (slime-connection)))) (defun slime-busy-p () "Return true if Lisp is busy processing a request." @@ -1717,28 +1745,33 @@ ;;; Stream output -(defvar slime-output-start (make-marker) - "Marker for the start of the output for the evaluation.") +(make-variable-buffer-local + (defvar slime-output-start nil + "Marker for the start of the output for the evaluation.")) -(defvar slime-output-end (let ((m (make-marker))) - (set-marker-insertion-type m t) - m) - "Marker for end of output. New output is inserted at this mark.") +(make-variable-buffer-local + (defvar slime-output-end nil + "Marker for end of output. New output is inserted at this mark.")) (defun slime-output-buffer () "Return the output buffer, create it if necessary." - (or (get-buffer "*slime-repl*") - (with-current-buffer (get-buffer-create "*slime-repl*") - (dolist (mark (list slime-output-start - slime-output-end - slime-repl-prompt-start-mark - slime-repl-input-start-mark - slime-repl-input-end-mark - slime-repl-last-input-start-mark)) - (set-marker mark (point))) - (slime-repl-mode) - (slime-repl-insert-prompt) - (current-buffer)))) + (or (slime-repl-buffer) + (let ((connection (slime-connection))) + (with-current-buffer (slime-repl-buffer t) + (slime-repl-mode) + (set (make-local-variable 'slime-connection) connection) + (dolist (markname (list 'slime-output-start + 'slime-output-end + 'slime-repl-prompt-start-mark + 'slime-repl-input-start-mark + 'slime-repl-input-end-mark + 'slime-repl-last-input-start-mark)) + (set markname (make-marker)) + (set-marker (symbol-value markname) (point))) + (set-marker-insertion-type slime-repl-input-end-mark t) + (set-marker-insertion-type slime-output-end t) + (slime-repl-insert-prompt) + (current-buffer))))) (defun slime-insert-transcript-delimiter (string) (with-current-buffer (slime-output-buffer) @@ -1845,18 +1878,28 @@ ;;; REPL -(defvar slime-repl-input-history '() - "History list of strings read from the REPL buffer.") +;; Small helper. +(defun slime-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(slime-make-variables-buffer-local + ;; Local variables in the REPL buffer. + (defvar slime-repl-input-history '() + "History list of strings read from the REPL buffer.") + + (defvar slime-repl-input-history-position 0) + + (defvar slime-repl-prompt-start-mark) + (defvar slime-repl-input-start-mark) + (defvar slime-repl-input-end-mark) + (defvar slime-repl-last-input-start-mark)) -(defvar slime-repl-input-history-position 0) (defvar slime-repl-mode-map) -(defvar slime-repl-prompt-start-mark (make-marker)) -(defvar slime-repl-input-start-mark (make-marker)) -(defvar slime-repl-input-end-mark (let ((m (make-marker))) - (set-marker-insertion-type m t) - m)) -(defvar slime-repl-last-input-start-mark (make-marker)) +(defun slime-repl-buffer (&optional create) + "Get the REPL buffer for the current connection; optionally create." + (funcall (if create #'get-buffer-create #'get-buffer) + (format "*slime-repl[%S]*" (slime-connection-number)))) (defun slime-repl-mode () "Major mode for interacting with a superior Lisp. @@ -3832,7 +3875,7 @@ (setq mode-name (format "sldb[%d]" (sldb-level))) (slime-set-truncate-lines) ;; Make original `slime-connection' "sticky" for SLDB commands in this buffer - (make-local-variable 'slime-connection) + (set (make-local-variable 'slime-connection) (slime-connection)) (make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'sldb-delete-overlays)) From lgorrie at common-lisp.net Wed Jan 7 00:12:22 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 06 Jan 2004 19:12:22 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8676 Modified Files: ChangeLog Log Message: Date: Tue Jan 6 19:12:22 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.185 slime/ChangeLog:1.186 --- slime/ChangeLog:1.185 Tue Jan 6 08:50:16 2004 +++ slime/ChangeLog Tue Jan 6 19:12:22 2004 @@ -1,3 +1,20 @@ +2004-01-07 Luke Gorrie + + * slime.el (slime): Multisession support: with prefix argument, + gives the option of keeping existing sessions and firing up an + additional *inferior-lisp* to connect to. Each connection now has + its own *slime-repl[]* buffer. + (slime-connection): Should now be read via the function of the + same name. The accessor will check if the value is NIL, and if so + use `slime-default-connection'. + (slime-default-connection): The connection that will be used by + default, i.e. unless `slime-connection' is bound. Renamed from + `slime-primary-connection'. + (slime-init-connection-state): When reconnecting, update the + `slime-connection' binding in the REPL to use the new connection. + (slime-repl-input-history, ...): REPL variables are now + buffer-local. + 2004-01-06 Helmut Eller * swank.lisp (eval-string): New argument 'id'. Used to identify From lgorrie at common-lisp.net Wed Jan 7 01:21:11 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 06 Jan 2004 20:21:11 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19680 Modified Files: slime.el Log Message: Multisession internal improvements. Now there are three separate connection variables, in order of priority: slime-dispatching-connection (dynamically-bound) slime-buffer-connection (buffer-local) slime-default-connection (global) The most specific one available is used. This is splitting `slime-connection' into multiple variables, so that you can be specific about what you want to assign (i.e. know if you're setting a dynamic binding or a buffer-local one). Fixed some related bugs. (slime-connection-close-hook): If default connection closes, select another connection. Date: Tue Jan 6 20:21:11 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.163 slime/slime.el:1.164 --- slime/slime.el:1.163 Tue Jan 6 19:12:02 2004 +++ slime/slime.el Tue Jan 6 20:21:10 2004 @@ -808,8 +808,7 @@ (current-buffer)))) (prog1 (progn , at body) (with-current-buffer standard-output - (set (make-local-variable 'slime-connection) - connection) + (setq slime-buffer-connection connection) (set (make-local-variable 'slime-temp-buffer-saved-window-configuration) ,config) (goto-char (point-min)) @@ -1108,22 +1107,20 @@ ;; High-level network connection management. ;; Handles multiple connections and "context-switching" between them. -(defvar slime-connection nil - "Network process currently in use. -This connection is used to make requests when the user invokes -commands. - -Can be bound dynamically to use a particular connection temporarily. -Can be bound buffer-locally to make a particular connection -\"sticky\" for commands in a particular buffer. +(defvar slime-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `slime-buffer-connection' and `slime-default-connection'.") -You should not read this variable directly. Use the function of -the same name instead.") +(make-variable-buffer-local + (defvar slime-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `slime-default-connection'.")) (defvar slime-default-connection nil - "Network process selected for top-level use. -This variable is only used to test whether some process is the -primary process.") + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`slime-dispatching-connection' or `slime-buffer-connection'.") (defvar slime-connection-counter 0 "Number of SLIME connections made, for generating serial numbers.") @@ -1134,17 +1131,23 @@ Bound in the connection's process-buffer.")) (defun slime-connection () - "Return the current connection." - (when (and slime-connection - (not (eq (process-status slime-connection) 'open))) - (if (and slime-default-connection - (y-or-n-p "Buffer's connection closed; switch to default? ")) - (setq slime-connection nil) - (error "Buffer's connection closed."))) - (or slime-connection + "Return the connection to use for Lisp interaction." + (or slime-dispatching-connection + (progn (slime-maybe-drop-buffer-connection) + slime-buffer-connection) slime-default-connection (error "No connection."))) +(defun slime-maybe-drop-buffer-connection () + "If the current buffer's connection is closed, offer to switch +to the default." + (when (and slime-buffer-connection + (not (eq (process-status slime-buffer-connection) 'open))) + (if (and slime-default-connection + (y-or-n-p "Buffer's connection closed; switch to default? ")) + (setq slime-buffer-connection nil) + (error "Buffer's connection closed.")))) + (defun slime-connection-number (&optional connection) (slime-with-connection-buffer (connection) slime-connection-number)) @@ -1166,10 +1169,9 @@ (message (format "Selected connection: %S" (slime-connection-number))))) (defun slime-connection-close-hook (process) - (when (eq process slime-connection) - (setq slime-connection nil)) (when (eq process slime-default-connection) - (setq slime-default-connection nil))) + (when slime-net-processes + (slime-select-connection (car slime-net-processes))))) (add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) @@ -1307,16 +1309,17 @@ (defun slime-init-connection (proc &optional select) "Initialize the stack machine." - (let ((slime-connection proc)) - (slime-init-connection-state) + (let ((slime-dispatching-connection proc)) + (slime-init-connection-state proc) (when (or select (null slime-default-connection)) (slime-select-connection proc)) - (sldb-cleanup))) + (sldb-cleanup) + proc)) -(defun slime-init-connection-state () +(defun slime-init-connection-state (proc) ;; To make life simpler for the user: if this is the only open ;; connection then reset the connection counter. - (when (equal slime-net-processes (list slime-connection)) + (when (equal slime-net-processes (list proc)) (setq slime-connection-counter 0)) (slime-with-connection-buffer () (setq slime-state-stack (list (slime-idle-state))) @@ -1325,7 +1328,7 @@ ;; REPL buffer already exists - update its local ;; `slime-connection' binding. (with-current-buffer repl-buffer - (setq slime-connection proc))) + (setq slime-buffer-connection proc))) (setf (slime-pid) (slime-eval '(swank:getpid))) (when slime-global-debugger-hook (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER")) @@ -1369,7 +1372,7 @@ "Dispatch an event to the current state. Certain \"out of band\" events are handled specially instead of going into the state machine." - (let ((slime-connection (or process (slime-connection)))) + (let ((slime-dispatching-connection (or process (slime-connection)))) (slime-log-event event) (unless (slime-handle-oob event) (funcall (slime-state-function (slime-current-state)) event)))) @@ -1759,7 +1762,7 @@ (let ((connection (slime-connection))) (with-current-buffer (slime-repl-buffer t) (slime-repl-mode) - (set (make-local-variable 'slime-connection) connection) + (setq slime-buffer-connection connection) (dolist (markname (list 'slime-output-start 'slime-output-end 'slime-repl-prompt-start-mark @@ -3085,10 +3088,10 @@ reading input. The result is a string (\"\" if no input was given)." (let ((minibuffer-setup-hook (cons (lexical-let ((package (slime-buffer-package)) - (connection slime-connection)) + (connection (slime-connection))) (lambda () (setq slime-buffer-package package) - (set (make-local-variable 'slime-connection) connection) + (setq slime-buffer-connection connection) (set-syntax-table lisp-mode-syntax-table))) minibuffer-setup-hook))) (read-from-minibuffer prompt initial-value slime-read-expression-map @@ -3874,8 +3877,8 @@ (setq sldb-level-in-buffer (sldb-level)) (setq mode-name (format "sldb[%d]" (sldb-level))) (slime-set-truncate-lines) - ;; Make original `slime-connection' "sticky" for SLDB commands in this buffer - (set (make-local-variable 'slime-connection) (slime-connection)) + ;; Make original slime-connection "sticky" for SLDB commands in this buffer + (setq slime-buffer-connection (slime-connection)) (make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'sldb-delete-overlays)) From lgorrie at common-lisp.net Wed Jan 7 01:21:22 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Tue, 06 Jan 2004 20:21:22 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20138 Modified Files: ChangeLog Log Message: Date: Tue Jan 6 20:21:22 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.186 slime/ChangeLog:1.187 --- slime/ChangeLog:1.186 Tue Jan 6 19:12:22 2004 +++ slime/ChangeLog Tue Jan 6 20:21:22 2004 @@ -1,4 +1,17 @@ 2004-01-07 Luke Gorrie + + * slime.el: Multisession internal improvements. Now there are + three separate connection variables, in order of priority: + slime-dispatching-connection (dynamically-bound) + slime-buffer-connection (buffer-local) + slime-default-connection (global) + The most specific one available is used. This is splitting + `slime-connection' into multiple variables, so that you can be + specific about what you want to assign (i.e. know if you're + setting a dynamic binding or a buffer-local one). + Fixed some related bugs. + (slime-connection-close-hook): If default connection closes, + select another connection. * slime.el (slime): Multisession support: with prefix argument, gives the option of keeping existing sessions and firing up an From kelly_jackson55 at yahoo.com Wed Jan 7 01:46:26 2004 From: kelly_jackson55 at yahoo.com (kelly jackson) Date: Wed, 07 Jan 04 01:46:26 GMT Subject: [slime-cvs] meet rea_l hot wo_men Message-ID: An HTML attachment was scrubbed... URL: From lgorrie at common-lisp.net Wed Jan 7 18:09:50 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 07 Jan 2004 13:09:50 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18913 Modified Files: slime.el Log Message: (slime-lisp-package): Initially CL-USER nickname instead of COMMON-LISP-USER (for REPL prompt). Date: Wed Jan 7 13:09:50 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.164 slime/slime.el:1.165 --- slime/slime.el:1.164 Tue Jan 6 20:21:10 2004 +++ slime/slime.el Wed Jan 7 13:09:50 2004 @@ -1224,7 +1224,7 @@ This is automatically synchronized from Lisp.") (slime-def-connection-var slime-lisp-package - "COMMON-LISP-USER" + "CL-USER" "The current package name of the Superior lisp. This is automatically synchronized from Lisp.") From lgorrie at common-lisp.net Wed Jan 7 18:10:43 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 07 Jan 2004 13:10:43 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26273 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jan 7 13:10:43 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.187 slime/ChangeLog:1.188 --- slime/ChangeLog:1.187 Tue Jan 6 20:21:22 2004 +++ slime/ChangeLog Wed Jan 7 13:10:43 2004 @@ -12,6 +12,8 @@ Fixed some related bugs. (slime-connection-close-hook): If default connection closes, select another connection. + (slime-lisp-package): Initially CL-USER nickname instead of + COMMON-LISP-USER (for REPL prompt). * slime.el (slime): Multisession support: with prefix argument, gives the option of keeping existing sessions and firing up an From vsedach at common-lisp.net Thu Jan 8 07:02:21 2004 From: vsedach at common-lisp.net (Vladimir Sedach) Date: Thu, 08 Jan 2004 02:02:21 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8737 Modified Files: swank.lisp swank-clisp.lisp Log Message: Minor update of CLISP backend (streams, portability). eval-region is now do-based (that loop was just waiting to be scratched :). Date: Thu Jan 8 02:02:20 2004 Author: vsedach Index: slime/swank.lisp diff -u slime/swank.lisp:1.87 slime/swank.lisp:1.88 --- slime/swank.lisp:1.87 Tue Jan 6 08:42:22 2004 +++ slime/swank.lisp Thu Jan 8 02:02:20 2004 @@ -475,20 +475,17 @@ "Evaluate STRING and return the result. If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package change, then send Emacs an update." - (let ((*package* *buffer-package*) - - values) - (unwind-protect - (with-input-from-string (stream string) - (loop for form = (read stream nil stream) - until (eq form stream) - do (progn - (setq - form) - (setq values (multiple-value-list (eval form))) - (force-output)) - finally (return (values values -)))) - (when (and package-update-p (not (eq *package* *buffer-package*))) - (send-to-emacs - (list :new-package (shortest-package-nickname *package*))))))) + (unwind-protect + (do ((*package* *buffer-package*) + (str-length (length string)) + (pos 0) + (form nil) + (return-value nil (multiple-value-list (eval form)))) + ((= pos str-length) (values return-value form)) + (multiple-value-setq (form pos) + (read-from-string string nil nil :start pos))) + (when (and package-update-p (not (eq *package* *buffer-package*))) + (send-to-emacs (list :new-package (shortest-package-nickname *package*)))))) (defun shortest-package-nickname (package) "Return the shortest nickname (or canonical name) of PACKAGE." Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.2 slime/swank-clisp.lisp:1.3 --- slime/swank-clisp.lisp:1.2 Fri Jan 2 13:23:14 2004 +++ slime/swank-clisp.lisp Thu Jan 8 02:02:20 2004 @@ -1,6 +1,6 @@ ;;;; SWANK support for CLISP. -;;;; Copyright (C) 2003 W. Jenkner, V. Sedach +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach ;;;; swank-clisp.lisp is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License as @@ -12,10 +12,11 @@ ;;; swank-allegro (I don't use allegro at all, but it's the shortest ;;; one and I found Helmut Eller's code there enlightening). -;;; Note that I use the current CVS version of CLISP and I haven't -;;; tested older versions. You need an image containing the "SOCKET", -;;; "LINUX" and "REGEXP" packages. You should also fetch the portable -;;; XREF from the CMU AI repository. +;;; This code is developed using the current CVS version of CLISP and +;;; CLISP 2.32 on Linux. Older versions may not work (2.29 and below +;;; are confirmed non-working; please upgrade). You need an image +;;; containing the "SOCKET", "REGEXP", and (optionally) "LINUX" +;;; packages. (in-package "SWANK") @@ -27,6 +28,7 @@ (setq *start-swank-in-background* nil) ;(setq *redirect-output* nil) +#+linux (defmacro without-interrupts (&body body) `(let ((sigact (linux:signal-action-retrieve linux:SIGINT))) (unwind-protect @@ -35,71 +37,79 @@ , at body) (linux:set-sigprocmask linux:SIG_UNBLOCK (linux:sa-mask sigact))))) +#-linux +(defmacro without-interrupts (body) + body) + (defun without-interrupts* (fun) (without-interrupts (funcall fun))) -(defslimefun getpid () (linux::getpid)) +#+linux (defslimefun getpid () (linux::getpid)) +#+unix (defslimefun getpid () (system::program-id)) +#+win32 (defslimefun getpid () (or (system::getenv "PID") -1)) +;; the above is likely broken; we need windows NT users! ;;; TCP Server -(defun create-swank-server (port &key (reuse-address t) - (announce #'simple-announce-function) - (background *start-swank-in-background*) - (close *close-swank-socket-after-setup*)) - "Create a Swank TCP server on `port'." - (declare (ignore reuse-address)) - (let ((server-socket (socket-server port))) - ;; :connect :passive :reuse-address reuse-address - (funcall announce (socket-server-port server-socket)) - (cond (background - (error "Starting swank server in background not implemented.")) - (t - (accept-loop server-socket close))))) - -(defun accept-loop (server-socket close) - (unwind-protect (cond (close (accept-one-client server-socket)) - (t (loop (accept-one-client server-socket)))) - (socket-server-close server-socket))) - -(defun accept-one-client (server-socket) - (request-loop - (socket-accept server-socket - :buffered nil - :element-type 'character - :external-format (ext:make-encoding - :charset 'charset:iso-8859-1 - :line-terminator :unix)))) - -(defun request-loop (stream) - (let* ((out (if *use-dedicated-output-stream* - (open-stream-to-emacs stream) - (make-instance 'slime-output-stream))) - (in (make-instance 'slime-input-stream)) - (io (make-two-way-stream in out))) - (do () ((serve-one-request stream out in io))))) - -(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) + (defun get-socket-stream (port announce close-socket-p) + (let ((socket (socket:socket-server port))) + (socket:socket-wait socket 0) + (funcall announce (socket:socket-server-port socket)) + (prog1 + (socket:socket-accept socket + :buffered nil + :element-type 'character + :external-format (ext:make-encoding + :charset 'charset:iso-8859-1 + :line-terminator :unix)) + (when close-socket-p + (socket:socket-server-close socket))))) + +(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) + "Read and process a request from a SWANK client. + The request is read from the socket as a sexp and then evaluated." (catch 'slime-toplevel (with-simple-restart (abort "Return to Slime toplevel.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (close *emacs-io*) - (return-from serve-one-request t))))) - nil) + (handler-case (read-from-emacs) + (ext:simple-charset-type-error (err) + (format *debug-io* "Wrong slime stream encoding:~%~A" err)) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (close *emacs-io* :abort t) + (when *use-dedicated-output-stream* + (close *slime-output* :abort t)) + (throw 'closed-connection + (print "Connection to emacs closed" *debug-io*))))))) (defun open-stream-to-emacs (*emacs-io*) - (let* ((listener (socket-server 0)) - (port (socket-server-port listener))) - (unwind-protect (progn - (eval-in-emacs `(slime-open-stream-to-lisp ,port)) - (socket-accept listener - :buffered t - :external-format charset:iso-8859-1 - :element-type 'character - )) - (socket-server-close listener)))) + "Return an output-stream to Emacs' output buffer." + (let* ((listener (socket:socket-server)) + (port (socket:socket-server-port listener))) + (unwind-protect + (prog2 + (eval-in-emacs `(slime-open-stream-to-lisp ,port)) + (socket:socket-accept listener + :buffered t + :external-format charset:iso-8859-1 + :element-type 'character)) + (socket:socket-server-close listener)))) + +(defun create-swank-server (port &key (announce #'simple-announce-function) + reuse-address + background + (close *close-swank-socket-after-setup*)) + (declare (ignore reuse-address background)) + (let* ((emacs (get-socket-stream port announce close)) + (slime-out (if *use-dedicated-output-stream* + (open-stream-to-emacs emacs) + (make-instance 'slime-output-stream))) + (slime-in (make-instance 'slime-input-stream)) + (slime-io (make-two-way-stream slime-in slime-out))) + (catch 'closed-connection + (loop (serve-request emacs slime-out slime-in slime-io))))) + +;;; Swank functions (defmethod arglist-string (fname) (declare (type string fname)) From lgorrie at common-lisp.net Thu Jan 8 16:47:53 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 08 Jan 2004 11:47:53 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7104 Modified Files: slime.el Log Message: (slime-inspector-fontify): Function to insert a string in a particular inspector face. Replaces macro-code-generation function `slime-inspector-expand-fontify'. Date: Thu Jan 8 11:47:53 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.165 slime/slime.el:1.166 --- slime/slime.el:1.165 Wed Jan 7 13:09:50 2004 +++ slime/slime.el Thu Jan 8 11:47:53 2004 @@ -4422,9 +4422,8 @@ (slime-inspector-mode) (current-buffer)))) -(defun slime-inspector-expand-fontify (face string) - `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) - ,string)) +(defun slime-inspector-fontify (face string) + (slime-add-face (intern (format "slime-inspector-%s-face" face)) string)) (defun slime-open-inspector (inspected-parts &optional point) (with-current-buffer (slime-inspector-buffer) @@ -4432,7 +4431,7 @@ (erase-buffer) (destructuring-bind (&key text type primitive-type parts) inspected-parts (macrolet ((fontify (face string) - (slime-inspector-expand-fontify face string))) + `(slime-inspector-fontify ',face ,string))) (insert (fontify topline text)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" From lgorrie at common-lisp.net Thu Jan 8 16:50:32 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 08 Jan 2004 11:50:32 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29712 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Jan 8 11:50:32 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.188 slime/ChangeLog:1.189 --- slime/ChangeLog:1.188 Wed Jan 7 13:10:43 2004 +++ slime/ChangeLog Thu Jan 8 11:50:31 2004 @@ -1,3 +1,10 @@ +2004-01-08 Luke Gorrie + + * slime.el (slime-inspector-fontify): Function to insert a string + in a particular inspector face. Replaces macro-code-generation + function `slime-inspector-expand-fontify'. Fixes a byte-compile + problem (macro was calling function not defined at compile-time). + 2004-01-07 Luke Gorrie * slime.el: Multisession internal improvements. Now there are From wjenkner at common-lisp.net Fri Jan 9 02:26:11 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Thu, 08 Jan 2004 21:26:11 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30243 Modified Files: swank-clisp.lisp Log Message: Add methods for GRAY:STREAM-READ-CHAR-NO-HANG and for the CLISP specific GRAY:STREAM-READ-CHAR-WILL-HANG-P. This should fix the behaviour of SYS::READ-FORM. Date: Thu Jan 8 21:26:10 2004 Author: wjenkner Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.3 slime/swank-clisp.lisp:1.4 --- slime/swank-clisp.lisp:1.3 Thu Jan 8 02:02:20 2004 +++ slime/swank-clisp.lisp Thu Jan 8 21:26:10 2004 @@ -49,6 +49,34 @@ #+win32 (defslimefun getpid () (or (system::getenv "PID") -1)) ;; the above is likely broken; we need windows NT users! + +;;; Gray streams + +;; From swank-gray.lisp. + +(defclass slime-input-stream (fundamental-character-input-stream) + ((buffer :initform "") (index :initform 0))) + +;; We have to define an additional method for the sake of the C +;; function listen_char (see src/stream.d), on which SYS::READ-FORM +;; depends. + +;; We could make do with either of the two methods below. + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))) + +;; This CLISP extension is what listen_char actually calls. The +;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit +;; more efficient to define it directly. + +(defmethod stream-read-char-will-hang-p ((s slime-input-stream)) + (with-slots (buffer index) s + (= index (length buffer)))) + + ;;; TCP Server (defun get-socket-stream (port announce close-socket-p) From wjenkner at common-lisp.net Fri Jan 9 02:27:44 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Thu, 08 Jan 2004 21:27:44 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3460 Modified Files: ChangeLog Log Message: Date: Thu Jan 8 21:27:44 2004 Author: wjenkner Index: slime/ChangeLog diff -u slime/ChangeLog:1.189 slime/ChangeLog:1.190 --- slime/ChangeLog:1.189 Thu Jan 8 11:50:31 2004 +++ slime/ChangeLog Thu Jan 8 21:27:44 2004 @@ -1,3 +1,9 @@ +2004-01-09 Wolfgang Jenkner + + * swank-clisp.lisp: Add methods for GRAY:STREAM-READ-CHAR-NO-HANG + and for the CLISP specific GRAY:STREAM-READ-CHAR-WILL-HANG-P. + This should fix the behaviour of SYS::READ-FORM. + 2004-01-08 Luke Gorrie * slime.el (slime-inspector-fontify): Function to insert a string From heller at common-lisp.net Fri Jan 9 18:51:19 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 09 Jan 2004 13:51:19 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20698 Modified Files: swank.lisp Log Message: (eval-region): Bind *package* outside the unwind-protect to detect updates. Date: Fri Jan 9 13:51:19 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.88 slime/swank.lisp:1.89 --- slime/swank.lisp:1.88 Thu Jan 8 02:02:20 2004 +++ slime/swank.lisp Fri Jan 9 13:51:18 2004 @@ -475,17 +475,18 @@ "Evaluate STRING and return the result. If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package change, then send Emacs an update." - (unwind-protect - (do ((*package* *buffer-package*) - (str-length (length string)) - (pos 0) - (form nil) - (return-value nil (multiple-value-list (eval form)))) - ((= pos str-length) (values return-value form)) - (multiple-value-setq (form pos) - (read-from-string string nil nil :start pos))) - (when (and package-update-p (not (eq *package* *buffer-package*))) - (send-to-emacs (list :new-package (shortest-package-nickname *package*)))))) + (let ((*package* *buffer-package*)) + (unwind-protect + (do ((length (length string)) + (pos 0) + (- nil) + (return-value nil (multiple-value-list (eval -)))) + ((= pos length) (values return-value -)) + (multiple-value-setq (- pos) + (read-from-string string nil nil :start pos))) + (when (and package-update-p (not (eq *package* *buffer-package*))) + (send-to-emacs (list :new-package + (shortest-package-nickname *package*))))))) (defun shortest-package-nickname (package) "Return the shortest nickname (or canonical name) of PACKAGE." From heller at common-lisp.net Fri Jan 9 18:56:08 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 09 Jan 2004 13:56:08 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16992 Modified Files: slime.el Log Message: Place (require 'cl) inside a eval-and-compile. (slime-with-connection-buffer): Move definition upwards before the first use. Date: Fri Jan 9 13:56:08 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.166 slime/slime.el:1.167 --- slime/slime.el:1.166 Thu Jan 8 11:47:53 2004 +++ slime/slime.el Fri Jan 9 13:56:08 2004 @@ -52,18 +52,18 @@ ;;; Dependencies, major global variables and constants +(eval-and-compile + (require 'cl) + (unless (fboundp 'define-minor-mode) + (require 'easy-mmode) + (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))) (require 'inf-lisp) -(require 'cl) (require 'pp) (require 'hideshow) (require 'hyperspec) (require 'font-lock) (when (featurep 'xemacs) (require 'overlay)) -(eval-when (compile load eval) - (unless (fboundp 'define-minor-mode) - (require 'easy-mmode) - (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))) (require 'easymenu) (defvar slime-path @@ -307,6 +307,10 @@ ;; Fake binding to coax `define-minor-mode' to create the keymap '((" " 'undefined))) +(defvar slime-state-name "[??]" + "Name of the current state of `slime-default-connection'. +For display in the mode-line.") + ;; Setup the mode-line to say when we're in slime-mode, and which CL ;; package we think the current buffer belongs to. (add-to-list 'minor-mode-alist @@ -1148,20 +1152,16 @@ (setq slime-buffer-connection nil) (error "Buffer's connection closed.")))) -(defun slime-connection-number (&optional connection) - (slime-with-connection-buffer (connection) - slime-connection-number)) - -(defvar slime-state-name "[??]" - "Name of the current state of `slime-default-connection'. -For display in the mode-line.") - (defmacro* slime-with-connection-buffer ((&optional process) &rest body) "Execute BODY in the process-buffer of PROCESS. If PROCESS is not specified, `slime-connection' is used." `(with-current-buffer (process-buffer (or ,process (slime-connection) (error "No connection"))) , at body)) + +(defun slime-connection-number (&optional connection) + (slime-with-connection-buffer (connection) + slime-connection-number)) (defun slime-select-connection (process) (setq slime-default-connection process) From heller at common-lisp.net Fri Jan 9 18:56:36 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 09 Jan 2004 13:56:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18112 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 9 13:56:36 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.190 slime/ChangeLog:1.191 --- slime/ChangeLog:1.190 Thu Jan 8 21:27:44 2004 +++ slime/ChangeLog Fri Jan 9 13:56:36 2004 @@ -1,3 +1,15 @@ +2004-01-09 Helmut Eller + + * slime.el: Place (require 'cl) inside a eval-and-compile. + (slime-with-connection-buffer): Move definition upwards before the + first use. + + * swank.lisp (eval-region): Bind *package* outside the + unwind-protect to detect updates. + + * swank-backend.lisp (debugger-info-for-emacs) + (find-function-locations): Doc fix. + 2004-01-09 Wolfgang Jenkner * swank-clisp.lisp: Add methods for GRAY:STREAM-READ-CHAR-NO-HANG From heller at common-lisp.net Fri Jan 9 19:42:25 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 09 Jan 2004 14:42:25 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30695 Modified Files: swank-backend.lisp Log Message: (debugger-info-for-emacs, find-function-locations): Doc fix. Date: Fri Jan 9 14:42:25 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.11 slime/swank-backend.lisp:1.12 --- slime/swank-backend.lisp:1.11 Fri Jan 2 03:21:08 2004 +++ slime/swank-backend.lisp Fri Jan 9 14:42:25 2004 @@ -5,7 +5,7 @@ ;;; Copyright (C) 2003, James Bielman ;;; Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.11 2004/01/02 08:21:08 heller Exp $ +;;; $Id: swank-backend.lisp,v 1.12 2004/01/09 19:42:25 heller Exp $ ;;; ;; This is a skeletal implementation of the Slime internals interface. @@ -219,13 +219,13 @@ (:documentation "Return debugger state, with stack frames from START to END. The result is a list: - (condition-description ({restart}*) ({stack-frame}*) + (condition ({restart}*) ({stack-frame}*) where + condition ::= (description type) restart ::= (name description) stack-frame ::= (number description) -condition-description---a string describing the condition that -triggered the debugger. +condition---a pair of strings: message, and type. restart---a pair of strings: restart name, and description. @@ -236,12 +236,12 @@ division by zero (multi-line description), and only one frame is being fetched (start=0, end=1). - (\"Arithmetic error DIVISION-BY-ZERO signalled. -Operation was KERNEL::DIVISION, operands (1 0). - [Condition of type DIVISION-BY-ZERO]\" + ((\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0).\" + \"[Condition of type DIVISION-BY-ZERO]\") ((\"ABORT\" \"Return to Slime toplevel.\") (\"ABORT\" \"Return to Top-Level.\")) - ((0 \"0: (KERNEL::INTEGER-/-INTEGER 1 0)\")))")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))")) (defgeneric backtrace (start end) (:documentation @@ -337,7 +337,10 @@ | (:source-form ) ::= (:position []) ; 1 based - | (:function-name )")) + | (:line []) + | (:function-name ) + | (:source-path ) +")) ;;;; Multiprocessing From heller at common-lisp.net Fri Jan 9 20:43:59 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 09 Jan 2004 15:43:59 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25665 Modified Files: slime.el Log Message: New test for package updates in the listeners. Date: Fri Jan 9 15:43:59 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.167 slime/slime.el:1.168 --- slime/slime.el:1.167 Fri Jan 9 13:56:08 2004 +++ slime/slime.el Fri Jan 9 15:43:59 2004 @@ -4786,6 +4786,22 @@ ;; Clear out old tests. (setq slime-tests nil) +(defun slime-test-state-stack (states) + "True if STATES describes the current stack of states." + (equal states (mapcar #'slime-state-name (slime-state-stack)))) + +(defun slime-sync-state-stack (state-stack timeout) + "Wait until the machine's stack is STATE-STACK or the timeout \ +expires.\nThe timeout is given in seconds (a floating point number)." + (let ((end (time-add (current-time) (seconds-to-time timeout)))) + (loop until (or (slime-test-state-stack state-stack) + (time-less-p end (current-time))) + do (accept-process-output nil 0 100000)))) + +(defun slime-check-idle-state (&optional test-name) + (slime-check ((or test-name "Automaton in idle state.")) + (slime-test-state-stack '(slime-idle-state)))) + (def-slime-test find-definition (name buffer-package) "Find the definition of a function or macro in swank.lisp." @@ -4870,9 +4886,7 @@ (def-slime-test async-eval-debugging (depth) "Test recursive debugging of asynchronous evaluation requests." '((1) (2) (3)) - (slime-check "Automaton initially in idle state." - ;; We expect to be at the top-level when the test starts. - (slime-test-state-stack '(slime-idle-state))) + (slime-check-idle-state "Automaton initially in idle state.") (lexical-let ((depth depth) (debug-hook-max-depth 0)) (let ((debug-hook @@ -4903,27 +4917,13 @@ debug-hook-max-depth depth) (= debug-hook-max-depth depth)) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))))))) - -(defun slime-test-state-stack (states) - "True if STATES describes the current stack of states." - (equal states (mapcar #'slime-state-name (slime-state-stack)))) - -(defun slime-sync-state-stack (state-stack timeout) - "Wait until the machine's stack is STATE-STACK or the timeout \ -expires.\nThe timeout is given in seconds (a floating point number)." - (let ((end (time-add (current-time) (seconds-to-time timeout)))) - (loop until (or (slime-test-state-stack state-stack) - (time-less-p end (current-time))) - do (accept-process-output nil 0 100000)))) + (slime-check-idle-state "Automaton is back in idle state."))))) (def-slime-test loop-interrupt-quit () "Test interrupting a loop." '(()) - (slime-check "Automaton initially in idle state." - (slime-test-state-stack '(slime-idle-state))) + (slime-check-idle-state "Automaton initially in idle state.") (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) (let ((sldb-hook (lambda () @@ -4938,15 +4938,13 @@ (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) (slime-interrupt) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))))) + (slime-check-idle-state "Automaton is back in idle state."))) (def-slime-test loop-interrupt-continue-interrupt-quit () "Test interrupting a previously interrupted but continued loop." '(()) - (slime-check "Automaton initially in idle state." - (slime-test-state-stack '(slime-idle-state))) + (slime-check-idle-state "Automaton initially in idle state.") (slime-eval-async '(cl:loop) "CL-USER" (lambda (_) )) (let ((sldb-hook (lambda () @@ -4984,8 +4982,7 @@ (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) (slime-interrupt) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))))) + (slime-check-idle-state "Automaton is back in idle state."))) (def-slime-test interactive-eval () @@ -4995,8 +4992,7 @@ (slime-interactive-eval "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))") (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))) + (slime-check-idle-state "Automaton is back in idle state.") (let ((message (current-message))) (slime-check "Minibuffer contains: \"=> 3\"" (equal "=> 3" message))))) @@ -5005,8 +5001,7 @@ () "Test interrupting a loop that sends a lot of output to Emacs." '(()) - (slime-check "Automaton initially in idle state." - (slime-test-state-stack '(slime-idle-state))) + (slime-check-idle-state "Automaton initially in idle state.") (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) (cl:force-output))) "CL-USER" (lambda (_) )) @@ -5023,9 +5018,26 @@ (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) (slime-interrupt) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state." - (slime-test-state-stack '(slime-idle-state))))) + (slime-check "Automaton is back in idle state."))) +(def-slime-test package-updateing + (package-name nickname) + "Test if slime-lisp-package is updated." + '(("COMMON-LISP" "CL") + ("KEYWORD" "KEYWORD") + ("COMMON-LISP-USER" "CL-USER")) + (with-current-buffer (slime-output-buffer) + (let ((p (slime-eval + `(swank:listener-eval + ,(format + "(cl:setq cl:*package* (cl:find-package %S)) + (cl:package-name cl:*package*)" package-name)) + (slime-lisp-package)))) + (slime-check ("In %s package." package-name) + (equal (format "\"%s\"" package-name) p)) + (slime-check ("slime-lisp-package is %s." nickname) + (equal (slime-lisp-package) nickname))))) + ;;; Portability library From heller at common-lisp.net Fri Jan 9 20:44:38 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 09 Jan 2004 15:44:38 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6720 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 9 15:44:38 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.191 slime/ChangeLog:1.192 --- slime/ChangeLog:1.191 Fri Jan 9 13:56:36 2004 +++ slime/ChangeLog Fri Jan 9 15:44:37 2004 @@ -3,6 +3,7 @@ * slime.el: Place (require 'cl) inside a eval-and-compile. (slime-with-connection-buffer): Move definition upwards before the first use. + (package-updateing): New test for package updates in the listeners. * swank.lisp (eval-region): Bind *package* outside the unwind-protect to detect updates. From lgorrie at common-lisp.net Fri Jan 9 21:40:26 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 09 Jan 2004 16:40:26 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30624 Modified Files: slime.el Log Message: (slime-activate-state): Only update state name when `slime-default-connection' activates. This fixes an annoying "Selecting deleted buffer" bug that prevented SLIME from being restarted. Date: Fri Jan 9 16:40:26 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.168 slime/slime.el:1.169 --- slime/slime.el:1.168 Fri Jan 9 15:43:59 2004 +++ slime/slime.el Fri Jan 9 16:40:26 2004 @@ -307,10 +307,6 @@ ;; Fake binding to coax `define-minor-mode' to create the keymap '((" " 'undefined))) -(defvar slime-state-name "[??]" - "Name of the current state of `slime-default-connection'. -For display in the mode-line.") - ;; Setup the mode-line to say when we're in slime-mode, and which CL ;; package we think the current buffer belongs to. (add-to-list 'minor-mode-alist @@ -1152,6 +1148,10 @@ (setq slime-buffer-connection nil) (error "Buffer's connection closed.")))) +(defvar slime-state-name "[??]" + "Name of the current state of `slime-default-connection'. +For display in the mode-line.") + (defmacro* slime-with-connection-buffer ((&optional process) &rest body) "Execute BODY in the process-buffer of PROCESS. If PROCESS is not specified, `slime-connection' is used." @@ -1159,10 +1159,6 @@ (process-buffer (or ,process (slime-connection) (error "No connection"))) , at body)) -(defun slime-connection-number (&optional connection) - (slime-with-connection-buffer (connection) - slime-connection-number)) - (defun slime-select-connection (process) (setq slime-default-connection process) (unless (get-buffer-window (slime-output-buffer) t) @@ -1173,6 +1169,10 @@ (when slime-net-processes (slime-select-connection (car slime-net-processes))))) +(defun slime-connection-number (&optional connection) + (slime-with-connection-buffer (connection) + slime-connection-number)) + (add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook) (defun slime-next-connection () @@ -1339,7 +1339,8 @@ This delivers an (activate) event to the state function, and updates the state name for the modeline." (let ((state (slime-current-state))) - (slime-update-state-name) + (when (eq (slime-connection) slime-default-connection) + (slime-update-state-name)) (slime-dispatch-event '(activate)))) (defun slime-update-state-name () From lgorrie at common-lisp.net Fri Jan 9 21:52:23 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 09 Jan 2004 16:52:23 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28544 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 9 16:52:23 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.192 slime/ChangeLog:1.193 --- slime/ChangeLog:1.192 Fri Jan 9 15:44:37 2004 +++ slime/ChangeLog Fri Jan 9 16:52:22 2004 @@ -1,3 +1,10 @@ +2004-01-09 Luke Gorrie + + * slime.el (slime-activate-state): Only update state name when + `slime-default-connection' activates. This fixes an annoying + "Selecting deleted buffer" bug that prevented SLIME from being + restarted. + 2004-01-09 Helmut Eller * slime.el: Place (require 'cl) inside a eval-and-compile. From lgorrie at common-lisp.net Fri Jan 9 23:00:26 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 09 Jan 2004 18:00:26 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13089 Modified Files: slime.el Log Message: (slime-next-connection): Fixed a bug where buffer-local connection bindings could get in the way and prevent the connection from actually changing. (slime-complete-restore-window-configuration): Wrap `set-window-configuration' in `save-excursion'. This fixes a problem where the cursor would end up in the wrong place after completion in XEmacs. Date: Fri Jan 9 18:00:26 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.169 slime/slime.el:1.170 --- slime/slime.el:1.169 Fri Jan 9 16:40:26 2004 +++ slime/slime.el Fri Jan 9 18:00:25 2004 @@ -1160,14 +1160,14 @@ , at body)) (defun slime-select-connection (process) - (setq slime-default-connection process) - (unless (get-buffer-window (slime-output-buffer) t) - (message (format "Selected connection: %S" (slime-connection-number))))) + (setq slime-default-connection process)) (defun slime-connection-close-hook (process) (when (eq process slime-default-connection) (when slime-net-processes - (slime-select-connection (car slime-net-processes))))) + (slime-select-connection (car slime-net-processes)) + (message (format "Default connection closed; switched to #%S" + (slime-connection-number)))))) (defun slime-connection-number (&optional connection) (slime-with-connection-buffer (connection) @@ -1181,10 +1181,12 @@ (interactive) (when (null slime-net-processes) (error "Not connected.")) - (let ((conn (nth (mod (1+ (or (position (slime-connection) slime-net-processes) 0)) + (let ((conn (nth (mod (1+ (or (position slime-default-connection slime-net-processes) + 0)) (length slime-net-processes)) slime-net-processes))) - (slime-select-connection conn))) + (slime-select-connection conn) + (message (format "Selected connection #%S" (slime-connection-number))))) (put 'slime-with-connection-buffer 'lisp-indent-function 1) @@ -2996,7 +2998,8 @@ (remove-hook 'pre-command-hook 'slime-complete-maybe-restore-window-confguration) (when slime-complete-saved-window-configuration - (set-window-configuration slime-complete-saved-window-configuration) + (save-excursion + (set-window-configuration slime-complete-saved-window-configuration)) (setq slime-complete-saved-window-configuration nil)) (when (get-buffer slime-completions-buffer-name) (bury-buffer slime-completions-buffer-name))) From lgorrie at common-lisp.net Fri Jan 9 23:09:01 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 09 Jan 2004 18:09:01 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26769 Modified Files: ChangeLog Log Message: Date: Fri Jan 9 18:09:01 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.193 slime/ChangeLog:1.194 --- slime/ChangeLog:1.193 Fri Jan 9 16:52:22 2004 +++ slime/ChangeLog Fri Jan 9 18:09:01 2004 @@ -4,6 +4,13 @@ `slime-default-connection' activates. This fixes an annoying "Selecting deleted buffer" bug that prevented SLIME from being restarted. + (slime-next-connection): Fixed a bug where buffer-local connection + bindings could get in the way and prevent the connection from + actually changing. + (slime-complete-restore-window-configuration): Wrap + `set-window-configuration' in `save-excursion'. This fixes a + problem where the cursor would end up in the wrong place after + completion in XEmacs. 2004-01-09 Helmut Eller From lgorrie at common-lisp.net Sat Jan 10 00:15:51 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 09 Jan 2004 19:15:51 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv2528 Modified Files: slime.el Log Message: (slime-complete-symbol): Use markers to hold the beginning and end of the completion prefix in case looking up completions causes insertions (e.g. GC announcements). Date: Fri Jan 9 19:15:50 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.170 slime/slime.el:1.171 --- slime/slime.el:1.170 Fri Jan 9 18:00:25 2004 +++ slime/slime.el Fri Jan 9 19:15:50 2004 @@ -3034,8 +3034,8 @@ (interactive) (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) (return-from slime-complete-symbol (comint-dynamic-complete-as-filename))) - (let* ((end (slime-symbol-end-pos)) - (beg (slime-symbol-start-pos)) + (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)) (completion-result (slime-completions prefix)) (completion-set (first completion-result)) From lgorrie at common-lisp.net Sat Jan 10 00:16:07 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 09 Jan 2004 19:16:07 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv4385 Modified Files: ChangeLog Log Message: Date: Fri Jan 9 19:16:07 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.194 slime/ChangeLog:1.195 --- slime/ChangeLog:1.194 Fri Jan 9 18:09:01 2004 +++ slime/ChangeLog Fri Jan 9 19:16:07 2004 @@ -1,3 +1,9 @@ +2004-01-10 Luke Gorrie + + * slime.el (slime-complete-symbol): Use markers to hold the + beginning and end of the completion prefix, in case looking up + completions causes insertions (e.g. GC announcements). + 2004-01-09 Luke Gorrie * slime.el (slime-activate-state): Only update state name when From lgorrie at common-lisp.net Sat Jan 10 06:43:53 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 10 Jan 2004 01:43:53 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15168 Modified Files: slime.el Log Message: * slime.el (package-updating): Expected package is now a list (can be any), since the shortest nickname is not standardized. e.g. USER or CL-USER for COMMON-LISP-USER. Date: Sat Jan 10 01:43:53 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.171 slime/slime.el:1.172 --- slime/slime.el:1.171 Fri Jan 9 19:15:50 2004 +++ slime/slime.el Sat Jan 10 01:43:52 2004 @@ -5022,14 +5022,15 @@ (slime-test-state-stack '(slime-evaluating-state slime-idle-state))) (slime-interrupt) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check "Automaton is back in idle state."))) + (slime-check "Automaton is back in idle state." + (slime-test-state-stack '(slime-idle-state))))) -(def-slime-test package-updateing - (package-name nickname) +(def-slime-test package-updating + (package-name nicknames) "Test if slime-lisp-package is updated." - '(("COMMON-LISP" "CL") - ("KEYWORD" "KEYWORD") - ("COMMON-LISP-USER" "CL-USER")) + '(("COMMON-LISP" ("CL")) + ("KEYWORD" ("" "KEYWORD")) + ("COMMON-LISP-USER" ("CL-USER" "USER"))) (with-current-buffer (slime-output-buffer) (let ((p (slime-eval `(swank:listener-eval @@ -5039,8 +5040,8 @@ (slime-lisp-package)))) (slime-check ("In %s package." package-name) (equal (format "\"%s\"" package-name) p)) - (slime-check ("slime-lisp-package is %s." nickname) - (equal (slime-lisp-package) nickname))))) + (slime-check ("slime-lisp-package is in %S." nicknames) + (member (slime-lisp-package) nicknames))))) ;;; Portability library From lgorrie at common-lisp.net Sat Jan 10 06:45:06 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 10 Jan 2004 01:45:06 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30912 Modified Files: swank-cmucl.lisp Log Message: Don't enable xref (let the user decide). (set-fd-non-blocking): Removed unused function. Miscellaneous refactoring of the networking code. Date: Sat Jan 10 01:45:05 2004 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.43 slime/swank-cmucl.lisp:1.44 --- slime/swank-cmucl.lisp:1.43 Fri Jan 2 13:23:14 2004 +++ slime/swank-cmucl.lisp Sat Jan 10 01:45:05 2004 @@ -4,20 +4,9 @@ (in-package :swank) -;; Turn on xref. [should we?] -(setf c:*record-xref-info* t) - (defun without-interrupts* (body) (sys:without-interrupts (funcall body))) -(defun set-fd-non-blocking (fd) - (flet ((fcntl (fd cmd arg) - (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg) - (or flags - (error "fcntl: ~A" (unix:get-unix-error-msg errno)))))) - (let ((flags (fcntl fd unix:F-GETFL 0))) - (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))) - ;;;; TCP server. @@ -36,49 +25,42 @@ (fd (ext:create-inet-listener port :stream :reuse-address reuse-address :host ip))) - (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd))) - (accept-loop fd background close))) - -(defun emacs-io (fd) - "Create a new fd-stream for fd." - (sys:make-fd-stream fd :input t :output t :element-type 'base-char)) + (funcall announce (tcp-port fd)) + (accept-clients fd background close))) -(defun add-input-handler (fd fn) - (system:add-fd-handler fd :input fn)) - -(defun accept-loop (fd background close) +(defun accept-clients (fd background close) "Accept clients on the the server socket FD. Use fd-handlers if BACKGROUND is non-nil. Close the server socket after the first client if CLOSE is non-nil, " - (cond (background - (add-input-handler - fd (lambda (fd) (accept-one-client fd background close)))) - (close - (accept-one-client fd background close)) - (t - (loop (accept-one-client fd background close))))) + (flet ((accept-client (&optional (fdes fd)) + (accept-one-client fd background close))) + (cond (background (add-input-handler fd #'accept-client)) + (close (accept-client)) + (t (loop (accept-client)))))) (defun accept-one-client (socket background close) (let ((fd (ext:accept-tcp-connection socket))) (when close (sys:invalidate-descriptor socket) (unix:unix-close socket)) - (request-loop fd background))) + (setup-request-loop fd background))) -(defun request-loop (fd background) - "Process all request from the socket FD." - (let* ((stream (emacs-io fd)) +(defun setup-request-loop (fd background) + "Setup request handling for connection FD. +If BACKGROUND is true, setup SERVE-EVENT handler and return immediately. +Otherwise enter a request handling loop until the connection closes." + (let* ((stream (make-emacs-io-stream fd)) (out (if *use-dedicated-output-stream* (open-stream-to-emacs stream) (make-slime-output-stream))) (in (make-slime-input-stream)) (io (make-two-way-stream in out))) - (cond (background - (add-input-handler - fd (lambda (fd) - (declare (ignore fd)) - (serve-one-request stream out in io)))) - (t (do () ((serve-one-request stream out in io))))))) + (flet ((serve-request (&optional fdes) + (declare (ignore fdes)) + (serve-one-request stream out in io))) + (if background + (add-input-handler fd #'serve-request) + (loop (serve-one-request stream out in io)))))) (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) "Read and process one request from a SWANK client. @@ -95,11 +77,31 @@ (return-from serve-one-request t))))) nil) +;;; +;;;;; Socket helpers. + +(defun tcp-port (fd) + "Return the TCP port of the socket represented by FD." + (nth-value 1 (ext::get-socket-host-and-port fd))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer." + (let* ((hostent (ext:lookup-host-entry hostname)) + (address (car (ext:host-entry-addr-list hostent)))) + (ext:htonl address))) + +(defun add-input-handler (fd fn) + (system:add-fd-handler fd :input fn)) + +(defun make-emacs-io-stream (fd) + "Create a new input/output fd-stream for FD." + (sys:make-fd-stream fd :input t :output t :element-type 'base-char)) + (defun open-stream-to-emacs (*emacs-io*) "Return an output-stream to Emacs' output buffer." (let* ((ip (resolve-hostname "localhost")) (listener (ext:create-inet-listener 0 :stream :host ip)) - (port (nth-value 1 (ext::get-socket-host-and-port listener)))) + (port (tcp-port listener))) (unwind-protect (progn (eval-in-emacs `(slime-open-stream-to-lisp ,port)) From lgorrie at common-lisp.net Sat Jan 10 06:52:23 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sat, 10 Jan 2004 01:52:23 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28960 Modified Files: ChangeLog Log Message: Date: Sat Jan 10 01:52:23 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.195 slime/ChangeLog:1.196 --- slime/ChangeLog:1.195 Fri Jan 9 19:16:07 2004 +++ slime/ChangeLog Sat Jan 10 01:52:23 2004 @@ -1,5 +1,13 @@ 2004-01-10 Luke Gorrie + * slime.el (package-updating): Expected package is now a list (can + be any), since the shortest nickname is not + standardized. e.g. USER or CL-USER for COMMON-LISP-USER. + + * swank-cmucl.lisp: Don't enable xref (let the user decide). + (set-fd-non-blocking): Removed unused function. + Miscellaneous refactoring of the networking code. + * slime.el (slime-complete-symbol): Use markers to hold the beginning and end of the completion prefix, in case looking up completions causes insertions (e.g. GC announcements). From lgorrie at common-lisp.net Mon Jan 12 00:50:33 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 19:50:33 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7987 Modified Files: slime.el Log Message: (slime-handle-oob): Added :open-dedicated-output-stream message, previously implemented with :%apply. (slime-repl-read-string, slime-repl-return-string): Pass integer argument to `slime-repl-read-mode' to set rather than toggle. (slime-events-buffer): Set `hs-block-start-regexp' before running `hs-minor-mode'. Date: Sun Jan 11 19:50:33 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.172 slime/slime.el:1.173 --- slime/slime.el:1.172 Sat Jan 10 01:43:52 2004 +++ slime/slime.el Sun Jan 11 19:50:33 2004 @@ -1393,6 +1393,9 @@ ((:new-features features) (setf (slime-lisp-features) features) t) + ((:open-dedicated-output-stream port) + (slime-open-stream-to-lisp port) + t) ((:%apply fn args) (apply (intern fn) args) t) @@ -1484,8 +1487,8 @@ (let ((buffer (get-buffer-create "*slime-events*"))) (with-current-buffer buffer (lisp-mode) - (hs-minor-mode) (set (make-local-variable 'hs-block-start-regexp) "^(") + (hs-minor-mode) (setq font-lock-defaults nil) (current-buffer))))) @@ -2290,11 +2293,11 @@ (slime-switch-to-output-buffer) (slime-mark-output-end) (slime-mark-input-start) - (slime-repl-read-mode t)) + (slime-repl-read-mode 1)) (defun slime-repl-return-string (string) (slime-dispatch-event `(:emacs-return-string ,string)) - (slime-repl-read-mode nil)) + (slime-repl-read-mode -1)) (defun slime-repl-read-break () (interactive) @@ -2302,7 +2305,7 @@ (defun slime-repl-abort-read () (with-current-buffer (slime-output-buffer) - (slime-repl-read-mode nil) + (slime-repl-read-mode -1) (message "Read aborted"))) @@ -4851,7 +4854,7 @@ "Lookup the argument list for FUNCTION-NAME. Confirm that EXPECTED-ARGLIST is displayed." '(("swank:start-server" - "(swank:start-server port-file-namestring)") + "(swank:start-server port-file)") ("swank::compound-prefix-match" "(swank::compound-prefix-match prefix target)")) (let ((arglist (slime-get-arglist function-name))) ; From lgorrie at common-lisp.net Mon Jan 12 00:51:33 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 19:51:33 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8732 Modified Files: swank-backend.lisp Log Message: (create-socket-server): Generic callback-driven TCP server interface. Replaces `create-swank-server', with the higher-level logic moved into swank.lisp. (emacs-connected): Invoked when Emacs initially connects, as a hook for backend implementations. (make-fn-streams): Interface for creating pairs of input/output streams that are backended by callback functions. Used to implement redirected-via-Emacs standard I/O streams. Date: Sun Jan 11 19:51:32 2004 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.12 slime/swank-backend.lisp:1.13 --- slime/swank-backend.lisp:1.12 Fri Jan 9 14:42:25 2004 +++ slime/swank-backend.lisp Sun Jan 11 19:51:32 2004 @@ -1,18 +1,12 @@ ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- ;;; -;;; slime-impl.lisp --- Slime interface reference implementation. +;;; slime-backend.lisp --- SLIME backend interface. ;;; -;;; Copyright (C) 2003, James Bielman -;;; Released into the public domain. +;;; Created by James Bielman in 2003. Released into the public domain. ;;; -;;; $Id: swank-backend.lisp,v 1.12 2004/01/09 19:42:25 heller Exp $ -;;; - -;; This is a skeletal implementation of the Slime internals interface. -;; -;; The idea is to create a de-facto standard interface that can be -;; used by editor <-> CL integration software, such as Slime. Vendors -;; are encouraged to comment on this interface. +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which swank-.lisp provides methods. (defpackage :swank (:use :common-lisp) @@ -25,6 +19,7 @@ #:call-with-conversation-lock #:compiler-notes-for-emacs #:completions + #:create-server #:create-swank-server #:describe-alien-enum #:describe-alien-struct @@ -98,35 +93,45 @@ (in-package :swank) -;;;; Conditions and Error Handling +;;;; TCP server -;; XXX need to specify restart behavior for errors/warnings? +(defgeneric create-socket-server (init-fn &key announce-fn port + accept-background handle-background loop) + (:documentation + "Create a callback-driven TCP server. +Initially a TCP listen socket is opened, and then ANNOUNCE-FN is +called with its port number for its argument. -(define-condition not-implemented-error (error) - ()) +When a client connects, first a two-way stream is created for I/O +on the socket, and then INIT-FN is called with the stream for its +argument. INIT-FN returns another function, HANDLER-FN, to be +called with no arguments each time the stream becomes readable. -(deftype severity () '(member :error :warning :style-warning :note)) +If LOOP is true (the default), the server continues accepting +clients until CLOSE-SOCKET-SERVER is called. Otherwise the server +is closed after a single client has connected. -;; Base condition type for compiler errors, warnings and notes. -(define-condition compiler-condition (condition) - ((original-condition - ;; The original condition thrown by the compiler if appropriate. - ;; May be NIL if a compiler does not report using conditions. - :initarg :original-condition - :accessor original-condition) +If BACKGROUND-ACCEPT is true (the default), this function +immediately after creating the socket, and accepts connections +asynchronously. + +If BACKGROUND-HANDLE is true (the default), the... FIXME.")) + +;;; Base condition for networking errors. +(define-condition network-error (error) ()) + +(defgeneric emacs-connected () + (:documentation + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. - (severity - :type severity - :initarg :severity - :accessor severity) - - (message - :initarg :message - :accessor message) - - (location - :initarg :location - :accessor location))) +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs.")) + +(defmethod no-applicable-method ((m (eql #'emacs-connected)) &rest _) + (declare (ignore _)) + nil) ;;;; Compilation @@ -134,7 +139,8 @@ (defgeneric call-with-compilation-hooks (func) (:documentation "Call FUNC with hooks to trigger SLDB on compiler errors.")) -(defmacro with-compilation-hooks ((&rest _) &body body) + +(defmacro with-compilation-hooks (() &body body) `(call-with-compilation-hooks (lambda () (progn , at body)))) (defgeneric compile-string-for-emacs (string &key buffer position) @@ -152,6 +158,44 @@ "Compile FILENAME signalling COMPILE-CONDITIONs. If LOAD-P is true, load the file after compilation.")) +;;;;; Compiler conditions + +(deftype severity () '(member :error :warning :style-warning :note)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + (location :initarg :location + :accessor location))) + +;;; +;;;; Streams + +(defgeneric make-fn-streams (input-fn output-fn) + (:documentation + "Return character input and output streams backended by functions. +When input is needed, INPUT-FN is called with no arguments to +return a string. +When output is ready, OUTPUT-FN is called with the output as its +argument. + +Output should be forced to OUTPUT-FN before calling INPUT-FN. + +The streams are returned as two values.")) + ;;;; Documentation @@ -412,21 +456,21 @@ Systems that do not support multiprocessing always signal an error.")) + ;;;;; Default implementation for non-MP systems ;;; Using NO-APPLICABLE-METHOD to supply a default implementation that ;;; works in systems that don't have multiprocessing. ;;; (Good or bad idea? -luke) -(defvar _ nil ; Good or bad idea? -luke - "Null variable -- can be used for ignored arguments. -Declared special, so no IGNORE declarations are necessary.") - (defmethod no-applicable-method ((m (eql #'startup-multiprocessing)) &rest _) + (declare (ignore _)) nil) (defmethod no-applicable-method ((m (eql #'thread-id)) &rest _) + (declare (ignore _)) nil) (defmethod no-applicable-method ((m (eql #'thread-name)) &rest _) + (declare (ignore _)) "The One True Thread") (defmethod no-applicable-method ((m (eql #'call-with-I/O-lock)) &rest args) @@ -435,7 +479,9 @@ &rest args) (funcall (first args))) (defmethod no-applicable-method ((m (eql #'wait-goahead)) &rest _) + (declare (ignore _)) t) (defmethod no-applicable-method ((m (eql #'give-goahead)) &rest _) + (declare (ignore _)) (error "SLIME multiprocessing not available")) From lgorrie at common-lisp.net Mon Jan 12 00:52:26 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 19:52:26 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12048 Modified Files: swank-cmucl.lisp Log Message: (create-socket-server): Generic TCP server driven by SERVE-EVENT. (serve-one-request, open-stream-to-emacs): Deleted. Now handled portably in swank.lisp. (make-fn-streams): Implement new stream-redirection interface. (slime-input-stream): New slot referencing output sibling, so it can be forced before input requests. Date: Sun Jan 11 19:52:26 2004 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.44 slime/swank-cmucl.lisp:1.45 --- slime/swank-cmucl.lisp:1.44 Sat Jan 10 01:45:05 2004 +++ slime/swank-cmucl.lisp Sun Jan 11 19:52:25 2004 @@ -10,77 +10,46 @@ ;;;; TCP server. -(defun resolve-hostname (name) - (let* ((hostent (ext:lookup-host-entry name)) - (address (car (ext:host-entry-addr-list hostent)))) - (ext:htonl address))) - -(defun create-swank-server (port &key (reuse-address t) - (address "localhost") - (announce #'simple-announce-function) - (background *start-swank-in-background*) - (close *close-swank-socket-after-setup*)) - "Create a SWANK TCP server." - (let* ((ip (resolve-hostname address)) - (fd (ext:create-inet-listener port :stream - :reuse-address reuse-address - :host ip))) - (funcall announce (tcp-port fd)) - (accept-clients fd background close))) - -(defun accept-clients (fd background close) - "Accept clients on the the server socket FD. Use fd-handlers if -BACKGROUND is non-nil. Close the server socket after the first client -if CLOSE is non-nil, " - (flet ((accept-client (&optional (fdes fd)) - (accept-one-client fd background close))) - (cond (background (add-input-handler fd #'accept-client)) - (close (accept-client)) - (t (loop (accept-client)))))) - -(defun accept-one-client (socket background close) - (let ((fd (ext:accept-tcp-connection socket))) - (when close - (sys:invalidate-descriptor socket) - (unix:unix-close socket)) - (setup-request-loop fd background))) - -(defun setup-request-loop (fd background) - "Setup request handling for connection FD. -If BACKGROUND is true, setup SERVE-EVENT handler and return immediately. -Otherwise enter a request handling loop until the connection closes." - (let* ((stream (make-emacs-io-stream fd)) - (out (if *use-dedicated-output-stream* - (open-stream-to-emacs stream) - (make-slime-output-stream))) - (in (make-slime-input-stream)) - (io (make-two-way-stream in out))) - (flet ((serve-request (&optional fdes) - (declare (ignore fdes)) - (serve-one-request stream out in io))) - (if background - (add-input-handler fd #'serve-request) - (loop (serve-one-request stream out in io)))))) - -(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) - "Read and process one request from a SWANK client. -The request is read from the socket as a sexp and then evaluated. -Return non-nil iff a reader-error occured." - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime toplevel.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*)) - (close *emacs-io*) - (return-from serve-one-request t))))) - nil) +(defmethod create-socket-server (init-fn &key announce-fn (port 0) + (accept-background t) + (handle-background t) + (loop t) + (host "localhost")) + (let* ((ip (resolve-hostname host)) + (fd (ext:create-inet-listener port :stream :reuse-address t :host ip))) + (funcall announce-fn (local-tcp-port fd)) + (setup-socket-accept fd init-fn accept-background handle-background loop))) + +(defun setup-socket-accept (fd init-fn accept-background handle-background loop) + (flet ((accept-client (&optional (fd fd)) + (accept-one-client fd init-fn handle-background (not loop)))) + (cond (accept-background (add-input-handler fd #'accept-client)) + (loop (loop (accept-client))) + (t (accept-client))))) + +(defun accept-one-client (listen-fd init-fn background close) + (let* ((client-fd (ext:accept-tcp-connection listen-fd)) + (socket-stream (make-socket-io-stream client-fd)) + (handler-fn (funcall init-fn socket-stream))) + (when close + (sys:invalidate-descriptor listen-fd) + (unix:unix-close listen-fd)) + (if background + (add-input-handler client-fd + (lambda (fdes) + (declare (ignore fdes)) + (funcall handler-fn))) + (loop (funcall handler-fn))))) + +(defmethod make-fn-streams (input-fn output-fn) + (let* ((output (make-slime-output-stream output-fn)) + (input (make-slime-input-stream input-fn output))) + (values input output))) ;;; ;;;;; Socket helpers. -(defun tcp-port (fd) +(defun local-tcp-port (fd) "Return the TCP port of the socket represented by FD." (nth-value 1 (ext::get-socket-host-and-port fd))) @@ -93,32 +62,22 @@ (defun add-input-handler (fd fn) (system:add-fd-handler fd :input fn)) -(defun make-emacs-io-stream (fd) +(defun make-socket-io-stream (fd) "Create a new input/output fd-stream for FD." (sys:make-fd-stream fd :input t :output t :element-type 'base-char)) -(defun open-stream-to-emacs (*emacs-io*) - "Return an output-stream to Emacs' output buffer." - (let* ((ip (resolve-hostname "localhost")) - (listener (ext:create-inet-listener 0 :stream :host ip)) - (port (tcp-port listener))) - (unwind-protect - (progn - (eval-in-emacs `(slime-open-stream-to-lisp ,port)) - (let ((fd (ext:accept-tcp-connection listener))) - (sys:make-fd-stream fd :output t))) - (ext:close-socket listener)))) - ;;;; Stream handling (defstruct (slime-output-stream - (:include lisp::lisp-stream - (lisp::misc #'sos/misc) - (lisp::out #'sos/out) - (lisp::sout #'sos/sout)) - (:conc-name sos.) - (:print-function %print-slime-output-stream)) + (:include lisp::lisp-stream + (lisp::misc #'sos/misc) + (lisp::out #'sos/out) + (lisp::sout #'sos/sout)) + (:conc-name sos.) + (:print-function %print-slime-output-stream) + (:constructor make-slime-output-stream (output-fn))) + (output-fn nil :type function) (buffer (make-string 512) :type string) (index 0 :type kernel:index) (column 0 :type kernel:index)) @@ -142,15 +101,15 @@ (defun sos/sout (stream string start end) (loop for i from start below end do (sos/out stream (aref string i)))) - + (defun sos/misc (stream operation &optional arg1 arg2) (declare (ignore arg1 arg2)) (case operation ((:force-output :finish-output) (let ((end (sos.index stream))) (unless (zerop end) - (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end))) - (setf (sos.index stream) 0)))) + (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end)) + (setf (sos.index stream) 0)))) (:charpos (sos.column stream)) (:line-length 75) (:file-position nil) @@ -160,20 +119,26 @@ (t (format *terminal-io* "~&~Astream: ~S~%" stream operation)))) (defstruct (slime-input-stream - (:include string-stream - (lisp::in #'sis/in) - (lisp::misc #'sis/misc)) - (:conc-name sis.) - (:print-function %print-slime-output-stream)) - (buffer "" :type string) - (index 0 :type kernel:index)) + (:include string-stream + (lisp::in #'sis/in) + (lisp::misc #'sis/misc)) + (:conc-name sis.) + (:print-function %print-slime-output-stream) + (:constructor make-slime-input-stream (input-fn sos))) + (input-fn nil :type function) + ;; We know our sibling output stream, so that we can force it before + ;; requesting input. + (sos nil :type slime-output-stream) + (buffer "" :type string) + (index 0 :type kernel:index)) (defun sis/in (stream eof-errorp eof-value) (declare (ignore eof-errorp eof-value)) (let ((index (sis.index stream)) (buffer (sis.buffer stream))) (when (= index (length buffer)) - (setf buffer (slime-read-string)) + (force-output (sis.sos stream)) + (setf buffer (funcall (sis.input-fn stream))) (setf (sis.buffer stream) buffer) (setf index 0)) (prog1 (aref buffer index) From lgorrie at common-lisp.net Mon Jan 12 00:55:21 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 19:55:21 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv694 Modified Files: swank.lisp Log Message: Taking over previously non-portable jobs: (start-server): Now only uses sockets code from the backend. (handle-request): Top-level request loop. (open-dedicated-output-stream): Dedicated output socket. (connection): New data structure that bundles together the things that constitute a connection to Emacs: socket-level stream and user-level redirected streams. Date: Sun Jan 11 19:55:21 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.89 slime/swank.lisp:1.90 --- slime/swank.lisp:1.89 Fri Jan 9 13:51:18 2004 +++ slime/swank.lisp Sun Jan 11 19:55:21 2004 @@ -16,12 +16,15 @@ (in-package :swank) +(declaim (optimize (debug 3))) + (defvar *swank-io-package* (let ((package (make-package "SWANK-IO-PACKAGE" :use '()))) (import '(nil t quote) package) package)) -(declaim (optimize (debug 3))) +(defvar *dispatching-connection* nil + "Connection currently being served.") (defconstant server-port 4005 "Default port for the Swank TCP server.") @@ -63,13 +66,62 @@ (export ',fun :swank))) -;;;; Setup and Hooks +;;;; Helper macros + +(defmacro with-conversation-lock (&body body) + `(call-with-conversation-lock (lambda () , at body))) + +(defmacro with-I/O-lock (&body body) + `(call-with-I/O-lock (lambda () , at body))) + +(defmacro with-io-redirection ((&optional (connection '*dispatching-connection*)) + &body body) + "Execute BODY with I/O redirection to CONNECTION. +If *REDIRECT-IO* is true, all standard I/O streams are redirected." + `(if *redirect-io* + (call-with-redirected-io ,connection (lambda () , at body)) + (progn , at body))) + +;;; +;;;; Connection datatype + +(defstruct (connection + (:conc-name connection.) + (:print-function %print-connection) + (:constructor make-connection (socket-io user-input user-output user-io))) + ;; Raw I/O stream of socket connection. + (socket-io nil :type stream) + ;; Streams that can be used for user interaction, with requests + ;; redirected to Emacs. These streams must be initialized but, + ;; depending on configuration, may not be used. + (user-input nil :type (or stream null)) + (user-output nil :type (or stream null)) + (user-io nil :type (or stream null))) + +(defun %print-connection (connection stream depth) + (declare (ignore depth)) + (print-unreadable-object (connection stream :type t :identity t))) + +;; Condition for SLIME protocol errors. +(define-condition slime-read-error (error) + ((condition :initarg :condition :reader slime-read-error.condition)) + (:report (lambda (condition stream) + (format stream "~A" (slime-read-error.condition condition))))) + + +;;;; TCP Server (defvar *start-swank-in-background* t) (defvar *close-swank-socket-after-setup* nil) (defvar *use-dedicated-output-stream* t) -(defun announce-server-port (file) +(defun start-server (port-file) + (create-socket-server #'init-connection + :announce-fn (announce-server-port-fn port-file) + :port 0 + :loop nil)) + +(defun announce-server-port-fn (file) (lambda (port) (with-open-file (s file :direction :output @@ -78,26 +130,69 @@ (format s "~S~%" port)) (simple-announce-function port))) +(defun init-connection (socket-io) + (emacs-connected) + (let ((connection (create-connection socket-io))) + (lambda () + (handle-request connection)))) + +(defun create-connection (socket-io) + (let ((output-fn (make-output-function socket-io)) + (input-fn (lambda () (read-user-input-from-emacs socket-io)))) + (multiple-value-bind (user-in user-out) (make-fn-streams input-fn output-fn) + (let ((user-io (make-two-way-stream user-in user-out))) + (make-connection socket-io user-in user-out user-io))))) + +(defun make-output-function (socket-io) + (if *use-dedicated-output-stream* + (let ((stream (open-dedicated-output-stream socket-io))) + (lambda (string) + (princ string stream) + (force-output stream))) + (lambda (string) + (send-output-to-emacs string socket-io)))) + +(defun open-dedicated-output-stream (socket-io) + "Open a dedicated output connection to the Emacs on SOCKET-IO. +Return an output stream suitable for writing program output. + +This is an optimized way for Lisp to deliver output to Emacs." + ;; We start a server process, ask Emacs to connect to it, and then + ;; return the socket's stream. + (let (stream) + (labels ((announce (port) + (send-to-emacs `(:open-dedicated-output-stream ,port) socket-io)) + (init (client-stream) + (setf stream client-stream) + #'handle) + (handle () + (error "Protocol error: received input on dedicated output socket."))) + (create-socket-server #'init + :announce-fn #'announce + :loop nil + :accept-background nil + :handle-background t) + (assert (streamp stream)) + stream))) + +(defun handle-request (connection) + "Read and respond to one request from CONNECTION." + (catch 'slime-toplevel + (with-simple-restart (abort "Return to SLIME toplevel.") + (let ((*dispatching-connection* connection)) + (with-io-redirection () + (handler-case (read-from-emacs) + (slime-read-error (e) + (when *swank-debug-p* + (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) + (close (connection.socket-io connection)) + (return-from handle-request t))))))) + nil) + (defun simple-announce-function (port) (when *swank-debug-p* (format *debug-io* "~&;; Swank started at port: ~D.~%" port))) -(defun start-server (port-file-namestring) - "Create a SWANK server and write its port number to the file -PORT-FILE-NAMESTRING in ascii text." - (create-swank-server - 0 :reuse-address t - :announce (announce-server-port port-file-namestring))) - - -;;;; Helper macros - -(defmacro with-conversation-lock (&body body) - `(call-with-conversation-lock (lambda () , at body))) - -(defmacro with-I/O-lock (&body body) - `(call-with-I/O-lock (lambda () , at body))) - ;;;; IO to Emacs ;;; @@ -114,36 +209,26 @@ ;;; These stream variables are all dynamically-bound during request ;;; processing. -(defvar *emacs-io* nil - "The raw TCP stream connected to Emacs.") - -(defvar *slime-output* nil - "Output stream for writing Lisp output text to Emacs.") - -(defvar *slime-input* nil - "Input stream to read user input from Emacs.") - -(defvar *slime-io* nil - "Two-way-stream built from *slime-input* and *slime-output*.") - -(defparameter *redirect-output* t +(defparameter *redirect-io* t "When non-nil redirect Lisp standard I/O to Emacs. Redirection is done while Lisp is processing a request for Emacs.") -(defun call-with-slime-streams (in out io fn args) - (if *redirect-output* - (let ((*standard-output* out) - (*slime-input* in) - (*slime-output* out) - (*slime-io* io) - (*error-output* out) - (*trace-output* out) - (*debug-io* io) - (*query-io* io) - (*standard-input* in) - (*terminal-io* io)) - (apply fn args)) - (apply fn args))) +(defun call-with-redirected-io (connection function) + "Call FUNCTION with I/O streams redirected via CONNECTION." + (let* ((io (connection.user-io connection)) + (in (connection.user-input connection)) + (out (connection.user-output connection)) + (*standard-output* out) + (*error-output* out) + (*trace-output* out) + (*debug-io* io) + (*query-io* io) + (*standard-input* in) + (*terminal-io* io)) + (funcall function))) + +(defun current-socket-io () + (connection.socket-io *dispatching-connection*)) (defvar *log-events* nil) @@ -153,36 +238,27 @@ (when *log-events* (apply #'format *terminal-io* format-string args))) -(defun read-from-emacs () +(defun read-from-emacs (&optional (stream (current-socket-io))) "Read and process a request from Emacs." - (let ((form (read-next-form))) + (let ((form (read-next-form stream))) (log-event "READ: ~S~%" form) - (call-with-slime-streams - *slime-input* *slime-output* *slime-io* - #'funcall form))) - -(define-condition slime-read-error (error) - ((condition :initarg :condition :reader slime-read-error.condition)) - (:report (lambda (condition stream) - (format stream "~A" (slime-read-error.condition condition))))) + (apply #'funcall form))) -(defun read-next-form () - "Read the next Slime request from *EMACS-IO* and return an -S-expression to be evaluated to handle the request. If an error -occurs during parsing, it will be noted and control will be tranferred -back to the main request handling loop." - (flet ((next-byte () (char-code (read-char *emacs-io*)))) +(defun read-next-form (stream) + "Read an S-expression from STREAM using the SLIME protocol. +If a protocol error occurs then a SLIME-READ-ERROR is signalled." + (flet ((next-byte () (char-code (read-char stream)))) (handler-case (with-I/O-lock (let* ((length (logior (ash (next-byte) 16) (ash (next-byte) 8) (next-byte))) (string (make-string length)) - (pos (read-sequence string *emacs-io*))) - (assert (= pos length) nil + (pos (read-sequence string stream))) + (assert (= pos length) () "Short read: length=~D pos=~D" length pos) (read-form string))) - (serious-condition (c) + (serious-condition (c) (error (make-condition 'slime-read-error :condition c)))))) (defun read-form (string) @@ -199,8 +275,8 @@ (setq *slime-features* *features*) (send-to-emacs (list :new-features (mapcar #'symbol-name *features*))))) -(defun send-to-emacs (object) - "Send `object' to Emacs." +(defun send-to-emacs (object &optional (output (current-socket-io))) + "Send OBJECT to over CONNECTION to Emacs." (let* ((string (prin1-to-string-for-emacs object)) (length (1+ (length string)))) (log-event "SEND: ~A~%" string) @@ -209,10 +285,10 @@ (lambda () (loop for position from 16 downto 0 by 8 do (write-char (code-char (ldb (byte 8 position) length)) - *emacs-io*)) - (write-string string *emacs-io*) - (terpri *emacs-io*) - (force-output *emacs-io*)))))) + output)) + (write-string string output) + (terpri output) + (force-output output)))))) (defun prin1-to-string-for-emacs (object) (with-standard-io-syntax @@ -222,24 +298,34 @@ (*package* *swank-io-package*)) (prin1-to-string object)))) - -;;;;; Input from Emacs +(defun force-user-output (&optional (connection *dispatching-connection*)) + (assert (connection-p connection)) + (force-output (connection.user-io connection)) + (force-output (connection.user-output connection))) + +(defun clear-user-input (&optional (connection *dispatching-connection*)) + (assert (connection-p connection)) + (clear-input (connection.user-input connection))) -(defvar *read-input-catch-tag* 0) +(defun send-output-to-emacs (string socket-io) + (send-to-emacs `(:read-output ,string) socket-io)) -(defun slime-read-string () - (force-output) - (force-output *slime-io*) +(defun read-user-input-from-emacs (socket-io) (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) - (send-to-emacs `(:read-string ,*read-input-catch-tag*)) - (let (ok) + (send-to-emacs `(:read-string ,*read-input-catch-tag*) socket-io) + (let ((ok nil)) (unwind-protect (prog1 (catch *read-input-catch-tag* - (loop (read-from-emacs))) + (loop (read-from-emacs socket-io))) (setq ok t)) (unless ok (send-to-emacs `(:read-aborted))))))) - + + +;;;;; Input from Emacs + +(defvar *read-input-catch-tag* 0) + (defslimefun take-input (tag input) (throw tag input)) @@ -325,19 +411,15 @@ globally. Must be run from the *slime-repl* buffer or somewhere else that the slime streams are visible so that it can capture them." (let ((package *buffer-package*) - (in *slime-input*) - (out *slime-output*) - (io *slime-io*) - (eio *emacs-io*)) + (connection *dispatching-connection*)) (labels ((slime-debug (c &optional next) (let ((*buffer-package* package) - (*emacs-io* eio)) + (*dispatching-connection* connection)) ;; check emacs is still there: don't want to end up ;; in recursive debugger loops if it's disconnected - (when (open-stream-p *emacs-io*) - (call-with-slime-streams - in out io - #'swank-debugger-hook (list c next)))))) + (when (open-stream-p (connection.socket-io connection)) + (with-io-redirection () + (swank-debugger-hook c next)))))) #'slime-debug))) (defslimefun install-global-debugger-hook () @@ -446,7 +528,7 @@ (force-output) (setq ok t)) (sync-state-to-emacs) - (force-output *slime-io*) + (force-user-output) (send-to-emacs `(:return ,(if ok `(:ok ,result) '(:abort)) ,id))))) (when *debugger-hook-passback* (setq *debugger-hook* *debugger-hook-passback*) @@ -486,7 +568,7 @@ (read-from-string string nil nil :start pos))) (when (and package-update-p (not (eq *package* *buffer-package*))) (send-to-emacs (list :new-package - (shortest-package-nickname *package*))))))) + (shortest-package-nickname *package*))))))) (defun shortest-package-nickname (package) "Return the shortest nickname (or canonical name) of PACKAGE." @@ -531,7 +613,7 @@ (package-name *package*)) (defslimefun listener-eval (string) - (clear-input *slime-input*) + (clear-user-input) (multiple-value-bind (values last-form) (eval-region string t) (setq +++ ++ ++ + + last-form *** ** ** * * (car values) @@ -837,7 +919,7 @@ (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name) (cond (foundp (print-description-to-string symbol)) - (t (format nil "Unkown symbol: ~S [in ~A]" + (t (format nil "Unknown symbol: ~S [in ~A]" symbol-name *buffer-package*))))) (defslimefun describe-function (symbol-name) From lgorrie at common-lisp.net Mon Jan 12 00:55:30 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 19:55:30 -0500 Subject: [slime-cvs] CVS update: slime/HACKING Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1249 Modified Files: HACKING Log Message: Date: Sun Jan 11 19:55:29 2004 Author: lgorrie Index: slime/HACKING diff -u slime/HACKING:1.1 slime/HACKING:1.2 --- slime/HACKING:1.1 Wed Dec 17 13:19:19 2003 +++ slime/HACKING Sun Jan 11 19:55:29 2004 @@ -9,9 +9,9 @@ vc-mode or pcl-cvs commit buffer. ChangeLog diffs are automatically sent to the slime-devel mailing list -each day as a digest summary of the slime-cvs list. +each day as a sort-of digest summary of the slime-cvs list. -For good tips on writing ChangeLog entries see the GNU Coding Standards: +There are good tips on writing ChangeLog entries in the GNU Coding Standards: http://www.gnu.org/prep/standards_40.html#SEC40 For information about Emacs's ChangeLog support see the `Change Log' @@ -43,6 +43,25 @@ Refactoring code to avoid direct calls from swank.lisp to functions defined in swank-.lisp is good for karma. +* Lisp code structure + +The ideal is to structure things like this: + + swank-backend.lisp: + Definition of the interface to non-portable features. + Stand-alone. + + swank-.lisp: + Backend implementation for a specific Common Lisp system. + Uses swank-backend.lisp. + + swank.lisp: + The top-level server program, built from the other components. + Uses swank-backend.lisp as an interface to the actual backends. + +Today things are more messy. Originally everything was in one file, +and we haven't finished the reorganisation yet. + * Calling Lisp from Emacs By convention our Elisp code only calls functions in the SWANK package @@ -77,6 +96,14 @@ outline. See the `Outline Mode' node of the Emacs manual for details: http://www.gnu.org/software/emacs/manual/html_node/emacs_246.html#SEC246 +Some tips to make the most of outline mode: + You can set `outline-minor-mode-prefix' for more convenient + keybindings, e.g. to [(control \;)]. + ` C-a' displays all levels. + `C-3 C-q' displays only top-level headings. + ` C-t' displays only/all headings. + ` {n,p}' for next/previous heading. + * Coding style We like the fact that each function in SLIME will fit on a single @@ -88,6 +115,6 @@ http://www.norvig.com/luv-slides.ps Remember that to rewrite a program better is the sincerest form of -code appreciation. If you can see a way to rewrite a part of SLIME +code appreciation. When you can see a way to rewrite a part of SLIME better, please do so! From lgorrie at common-lisp.net Mon Jan 12 00:55:38 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 19:55:38 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1280 Modified Files: ChangeLog Log Message: Date: Sun Jan 11 19:55:38 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.196 slime/ChangeLog:1.197 --- slime/ChangeLog:1.196 Sat Jan 10 01:52:23 2004 +++ slime/ChangeLog Sun Jan 11 19:55:38 2004 @@ -1,3 +1,42 @@ +2004-01-12 Luke Gorrie + + * slime.el (slime-handle-oob): Added + :open-dedicated-output-stream message, previously implemented + with :%apply. + (slime-repl-read-string, slime-repl-return-string): Pass integer + argument to `slime-repl-read-mode' to set rather than toggle. + + * swank.lisp: Taking over previously non-portable jobs: + (start-server): Now only uses sockets code from the backend. + (handle-request): Top-level request loop. + (open-dedicated-output-stream): Dedicated output socket. + (connection): New data structure that bundles together the things + that constitute a connection to Emacs: socket-level stream and + user-level redirected streams. + + * swank-cmucl.lisp (create-socket-server): Generic TCP server + driven by SERVE-EVENT. + (serve-one-request, open-stream-to-emacs): Deleted. Now handled + portably in swank.lisp. + (make-fn-streams): Implement new stream-redirection interface. + (slime-input-stream): New slot referencing output sibling, so it + can be forced before input requests. + + * swank-backend.lisp (create-socket-server): Generic + callback-driven TCP server interface. Replaces + `create-swank-server', with the higher-level logic moved into + swank.lisp. + (emacs-connected): Invoked when Emacs initially connects, as a + hook for backend implementations. + (make-fn-streams): Interface for creating pairs of input/output + streams that are backended by callback functions. Used to + implement redirected-via-Emacs standard I/O streams. + +2004-01-12 Lawrence Mitchell + + * slime.el (slime-events-buffer): Set `hs-block-start-regexp' + before running `hs-minor-mode'. + 2004-01-10 Luke Gorrie * slime.el (package-updating): Expected package is now a list (can From lgorrie at common-lisp.net Mon Jan 12 02:14:03 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 21:14:03 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21620 Modified Files: swank-sbcl.lisp Log Message: Implemented new server interface. Date: Sun Jan 11 21:14:03 2004 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.45 slime/swank-sbcl.lisp:1.46 --- slime/swank-sbcl.lisp:1.45 Fri Jan 2 13:23:14 2004 +++ slime/swank-sbcl.lisp Sun Jan 11 21:14:03 2004 @@ -61,6 +61,43 @@ ;;; TCP Server + +(defmethod create-socket-server (init-fn &key announce-fn (port 0) + (accept-background t) + (handle-background t) + (loop t) + (reuse-address t)) + (let ((socket (open-listener port reuse-address))) + (funcall announce-fn (local-tcp-port socket)) + (setup-socket-accept socket init-fn accept-background handle-background loop))) + +(defun setup-socket-accept (socket init-fn accept-background handle-background loop) + (flet ((accept-client (&optional fd) + (declare (ignore fd)) + (accept-one-client socket init-fn handle-background (not loop)))) + (cond (accept-background (add-input-handler socket #'accept-client)) + (loop (loop (accept-client))) + (t (accept-client))))) + +(defun accept-one-client (server-socket init-fn background close) + (let* ((client-socket (accept server-socket)) + (socket-stream (make-socket-io-stream client-socket)) + (handler-fn (funcall init-fn socket-stream))) + (when close + (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor + server-socket)) + (sb-bsd-sockets:socket-close server-socket)) + (if background + (add-input-handler client-socket + (lambda (fdes) + (declare (ignore fdes)) + (funcall handler-fn))) + (loop (funcall handler-fn))))) + +(defun add-input-handler (socket handler-fn) + (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) + :input handler-fn)) + (defun open-listener (port reuse-address) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream @@ -72,70 +109,29 @@ (sb-bsd-sockets:socket-listen socket 5) socket)) +(defun local-tcp-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defun make-socket-io-stream (socket) + (sb-bsd-sockets:socket-make-stream socket + :output t + :input t + :element-type 'base-char)) + + (defun accept (socket) "Like socket-accept, but retry on EAGAIN." (loop (handler-case (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) -(defun create-swank-server (port &key (reuse-address t) - (announce #'simple-announce-function)) - "Create a SWANK TCP server." - (let ((socket (open-listener port reuse-address))) - (sb-sys:add-fd-handler - (sb-bsd-sockets:socket-file-descriptor socket) - :input (lambda (fd) - (declare (ignore fd)) - (accept-connection socket))) - (funcall announce (nth-value 1 (sb-bsd-sockets:socket-name socket))))) - -(defun open-stream-to-emacs () - (let* ((server-socket (open-listener 0 t)) - (port (nth-value 1 (sb-bsd-sockets:socket-name server-socket)))) - (unwind-protect - (progn - (eval-in-emacs `(slime-open-stream-to-lisp ,port)) - (let ((socket (accept server-socket))) - (sb-bsd-sockets:socket-make-stream - socket :output t :element-type 'base-char))) - (sb-bsd-sockets:socket-close server-socket)))) - -(defvar *use-dedicated-output-stream* t) - -(defun accept-connection (server-socket) - "Accept one Swank TCP connection on SERVER-SOCKET and then close it." - (let* ((socket (accept server-socket)) - (stream (sb-bsd-sockets:socket-make-stream - socket :input t :output t :element-type 'base-char)) - (out (if *use-dedicated-output-stream* - (let ((*emacs-io* stream)) (open-stream-to-emacs)) - (make-instance 'slime-output-stream))) - (in (make-instance 'slime-input-stream)) - (io (make-two-way-stream in out))) - ;; we're being called from a serve-event handler: remove it now - ;; because socket-close doesn't (in 0.8.6 anyway) do it for us - (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor - server-socket)) - (sb-bsd-sockets:socket-close server-socket) - (sb-sys:add-fd-handler - (sb-bsd-sockets:socket-file-descriptor socket) - :input (lambda (fd) - (declare (ignore fd)) - (serve-request stream out in io))))) - - -(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) - "Read and process a request from a SWANK client. -The request is read from the socket as a sexp and then evaluated." - (catch 'slime-toplevel - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (sb-sys:invalidate-descriptor (sb-impl::fd-stream-fd *emacs-io*)) - (close *emacs-io* :abort t) - (when *use-dedicated-output-stream* - (close *slime-output* :abort t)))))) +(defmethod make-fn-streams (input-fn output-fn) + (let* ((output (make-instance 'slime-output-stream + :output-fn output-fn)) + (input (make-instance 'slime-input-stream + :input-fn input-fn + :output-stream output))) + (values input output))) ;;; Utilities From lgorrie at common-lisp.net Mon Jan 12 02:14:18 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 21:14:18 -0500 Subject: [slime-cvs] CVS update: slime/swank-gray.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25140 Modified Files: swank-gray.lisp Log Message: (slime-input-stream, slime-output-buffer): Added slots to support the new `make-fn-streams' interface from swank-backend.lisp. These slots need to be initialized by the backend, see swank-sbcl.lisp for an example (very easy). Date: Sun Jan 11 21:14:17 2004 Author: lgorrie Index: slime/swank-gray.lisp diff -u slime/swank-gray.lisp:1.1 slime/swank-gray.lisp:1.2 --- slime/swank-gray.lisp:1.1 Sun Nov 16 12:46:59 2003 +++ slime/swank-gray.lisp Sun Jan 11 21:14:17 2004 @@ -7,13 +7,14 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-gray.lisp,v 1.1 2003/11/16 17:46:59 heller Exp $ +;;; $Id: swank-gray.lisp,v 1.2 2004/01/12 02:14:17 lgorrie Exp $ ;;; (in-package :swank) (defclass slime-output-stream (fundamental-character-output-stream) - ((buffer :initform (make-string 512)) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 512)) (fill-pointer :initform 0) (column :initform 0))) @@ -35,20 +36,24 @@ 75) (defmethod stream-force-output ((stream slime-output-stream)) - (with-slots (buffer fill-pointer) stream + (with-slots (buffer fill-pointer output-fn) stream (let ((end fill-pointer)) (unless (zerop end) - (send-to-emacs `(:read-output ,(subseq buffer 0 end))) + (funcall output-fn (subseq buffer 0 end)) (setf fill-pointer 0)))) nil) (defclass slime-input-stream (fundamental-character-input-stream) - ((buffer :initform "") (index :initform 0))) + ((output-stream :initarg :output-stream) + (input-fn :initarg :input-fn) + (buffer :initform "") (index :initform 0))) (defmethod stream-read-char ((s slime-input-stream)) - (with-slots (buffer index) s + (with-slots (buffer index output-stream input-fn) s (when (= index (length buffer)) - (setf buffer (slime-read-string)) + (when output-stream + (force-output output-stream)) + (setf buffer (funcall input-fn)) (setf index 0)) (assert (plusp (length buffer))) (prog1 (aref buffer index) (incf index)))) From lgorrie at common-lisp.net Mon Jan 12 02:14:25 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 21:14:25 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25532 Modified Files: ChangeLog Log Message: Date: Sun Jan 11 21:14:25 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.197 slime/ChangeLog:1.198 --- slime/ChangeLog:1.197 Sun Jan 11 19:55:38 2004 +++ slime/ChangeLog Sun Jan 11 21:14:25 2004 @@ -1,5 +1,13 @@ 2004-01-12 Luke Gorrie + * swank-gray.lisp (slime-input-stream, slime-output-buffer): Added + slots to support the new `make-fn-streams' interface from + swank-backend.lisp. These slots need to be initialized by the + backend, see swank-sbcl.lisp for an example (very easy). + + * swank-sbcl.lisp (create-socket-server): Implemented new server + interface. + * slime.el (slime-handle-oob): Added :open-dedicated-output-stream message, previously implemented with :%apply. From lgorrie at common-lisp.net Mon Jan 12 04:30:27 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 23:30:27 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11040 Modified Files: swank-lispworks.lisp Log Message: Partially updated for new backend interface, but not actually working. The sockets code is broken, I haven't grokked LispWorks the interface properly. Date: Sun Jan 11 23:30:27 2004 Author: lgorrie Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.10 slime/swank-lispworks.lisp:1.11 --- slime/swank-lispworks.lisp:1.10 Fri Jan 2 13:23:14 2004 +++ slime/swank-lispworks.lisp Sun Jan 11 23:30:27 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.10 2004/01/02 18:23:14 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.11 2004/01/12 04:30:27 lgorrie Exp $ ;;; (in-package :swank) @@ -30,56 +30,58 @@ (defun without-interrupts* (body) (lispworks:without-interrupts (funcall body))) -(defun create-swank-server (port &key (reuse-address t) - (announce #'simple-announce-function)) - "Create a Swank TCP server on `port'. -Return the port number that the socket is actually listening on." - (declare (ignore reuse-address)) +(defconstant +sigint+ 2) + +(defmethod create-socket-server (init-fn &key announce-fn (port 0) + (accept-background t) + (handle-background t) + (loop t)) (flet ((sentinel (socket condition) (cond (socket (let ((port (nth-value 1 (comm:get-socket-address socket)))) - (funcall announce port))) + (funcall announce-fn port))) (t (format *terminal-io* ";; Swank condition: ~A~%" - condition))))) - (comm:start-up-server :announce #'sentinel :service port - :process-name "Swank server" - :function 'swank-accept-connection))) + condition)))) + (accept (fd) + (accept-connection fd init-fn handle-background) + (unless loop (mp:process-kill mp:*current-process*)))) + (let ((server-process + (comm:start-up-server :announce #'sentinel :service port + :process-name "Swank server" + :function #'accept))) + (unless accept-background + (wait-process-death server-process))))) + +(defun accept-connection (fd init-fn background) + (let ((socket-io (make-instance 'comm:socket-stream + :socket fd + :direction :io + :element-type 'base-char))) + (sys:set-signal-handler +sigint+ #'sigint-handler) + (let* ((handler-fn (funcall init-fn socket-io)) + (loop-fn (lambda () (loop (funcall handler-fn))))) + (if background + (mp:process-run-function "Swank request handler" () loop-fn) + (funcall loop-fn))))) + +(defun wait-process-death (process) + (mp:process-wait "Letting Emacs connect" + (lambda () (not (mp:process-alive-p process))))) -(defconstant +sigint+ 2) (defun sigint-handler (&rest args) (declare (ignore args)) (invoke-debugger "SIGINT")) -(defun swank-accept-connection (fd) - "Accept one Swank TCP connection on SOCKET and then close it. -Run the connection handler in a new thread." - (let ((*emacs-io* (make-instance 'comm:socket-stream - :socket fd - :direction :io - :element-type 'base-char))) - (sys:set-signal-handler +sigint+ #'sigint-handler) - (request-loop))) +(defmethod make-fn-streams (input-fn output-fn) + (let* ((output (make-instance 'slime-output-stream + :output-fn output-fn)) + (input (make-instance 'slime-input-stream + :input-fn input-fn + :output-stream output))) + (values input output))) -(defun request-loop () - "Thread function for a single Swank connection. Processes requests -until the remote Emacs goes away." - (unwind-protect - (let* ((*slime-output* (make-instance 'slime-output-stream)) - (*slime-input* (make-instance 'slime-input-stream)) - (*slime-io* (make-two-way-stream *slime-input* *slime-output*))) - (loop - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime event loop.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* - "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (return))))))) - (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*) - (close *emacs-io*))) (defslimefun getpid () "Return the process ID of this superior Lisp." From lgorrie at common-lisp.net Mon Jan 12 04:31:32 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 23:31:32 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14088 Modified Files: swank.lisp Log Message: Bugfix: moved some specials up to before they're referenced. Date: Sun Jan 11 23:31:31 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.90 slime/swank.lisp:1.91 --- slime/swank.lisp:1.90 Sun Jan 11 19:55:21 2004 +++ slime/swank.lisp Sun Jan 11 23:31:31 2004 @@ -50,6 +50,10 @@ *debugger-hook*, which is shadowed in a dynamic binding while they run.") +(defparameter *redirect-io* t + "When non-nil redirect Lisp standard I/O to Emacs. +Redirection is done while Lisp is processing a request for Emacs.") + ;;; public interface. slimefuns are the things that emacs is allowed ;;; to call @@ -209,10 +213,6 @@ ;;; These stream variables are all dynamically-bound during request ;;; processing. -(defparameter *redirect-io* t - "When non-nil redirect Lisp standard I/O to Emacs. -Redirection is done while Lisp is processing a request for Emacs.") - (defun call-with-redirected-io (connection function) "Call FUNCTION with I/O streams redirected via CONNECTION." (let* ((io (connection.user-io connection)) @@ -310,6 +310,8 @@ (defun send-output-to-emacs (string socket-io) (send-to-emacs `(:read-output ,string) socket-io)) +(defvar *read-input-catch-tag* 0) + (defun read-user-input-from-emacs (socket-io) (let ((*read-input-catch-tag* (1+ *read-input-catch-tag*))) (send-to-emacs `(:read-string ,*read-input-catch-tag*) socket-io) @@ -320,11 +322,6 @@ (setq ok t)) (unless ok (send-to-emacs `(:read-aborted))))))) - - -;;;;; Input from Emacs - -(defvar *read-input-catch-tag* 0) (defslimefun take-input (tag input) (throw tag input)) From lgorrie at common-lisp.net Mon Jan 12 04:31:47 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Sun, 11 Jan 2004 23:31:47 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14145 Modified Files: ChangeLog Log Message: Date: Sun Jan 11 23:31:47 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.198 slime/ChangeLog:1.199 --- slime/ChangeLog:1.198 Sun Jan 11 21:14:25 2004 +++ slime/ChangeLog Sun Jan 11 23:31:47 2004 @@ -1,5 +1,9 @@ 2004-01-12 Luke Gorrie + * swank-lispworks.lisp: Partially updated for new backend + interface, but not actually working. The sockets code is broken, I + haven't grokked LispWorks the interface properly. + * swank-gray.lisp (slime-input-stream, slime-output-buffer): Added slots to support the new `make-fn-streams' interface from swank-backend.lisp. These slots need to be initialized by the From vsedach at common-lisp.net Mon Jan 12 05:05:05 2004 From: vsedach at common-lisp.net (Vladimir Sedach) Date: Mon, 12 Jan 2004 00:05:05 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19072 Modified Files: swank-clisp.lisp Log Message: Added support for the new backend. Date: Mon Jan 12 00:05:05 2004 Author: vsedach Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.4 slime/swank-clisp.lisp:1.5 --- slime/swank-clisp.lisp:1.4 Thu Jan 8 21:26:10 2004 +++ slime/swank-clisp.lisp Mon Jan 12 00:05:04 2004 @@ -24,7 +24,7 @@ (use-package "SOCKET") (use-package "GRAY")) -;(setq *use-dedicated-output-stream* nil) +(setq *use-dedicated-output-stream* nil) (setq *start-swank-in-background* nil) ;(setq *redirect-output* nil) @@ -79,63 +79,37 @@ ;;; TCP Server - (defun get-socket-stream (port announce close-socket-p) - (let ((socket (socket:socket-server port))) - (socket:socket-wait socket 0) - (funcall announce (socket:socket-server-port socket)) - (prog1 - (socket:socket-accept socket - :buffered nil - :element-type 'character - :external-format (ext:make-encoding - :charset 'charset:iso-8859-1 - :line-terminator :unix)) - (when close-socket-p - (socket:socket-server-close socket))))) - -(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*) - "Read and process a request from a SWANK client. - The request is read from the socket as a sexp and then evaluated." - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime toplevel.") - (handler-case (read-from-emacs) - (ext:simple-charset-type-error (err) - (format *debug-io* "Wrong slime stream encoding:~%~A" err)) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (close *emacs-io* :abort t) - (when *use-dedicated-output-stream* - (close *slime-output* :abort t)) - (throw 'closed-connection - (print "Connection to emacs closed" *debug-io*))))))) - -(defun open-stream-to-emacs (*emacs-io*) - "Return an output-stream to Emacs' output buffer." - (let* ((listener (socket:socket-server)) - (port (socket:socket-server-port listener))) +(defmethod create-socket-server (init-fn &key announce-fn (port 0) + (accept-background nil) + (handle-background nil) + (loop nil) + (reuse-address nil)) + (declare (ignore loop reuse-address accept-background handle-background)) + (let* ((slime-stream (get-socket-stream port announce-fn)) + (handler-fn (funcall init-fn slime-stream))) + (loop (funcall handler-fn)))) + +(defun get-socket-stream (port announce) + (let ((socket (socket:socket-server port))) (unwind-protect - (prog2 - (eval-in-emacs `(slime-open-stream-to-lisp ,port)) - (socket:socket-accept listener - :buffered t - :external-format charset:iso-8859-1 - :element-type 'character)) - (socket:socket-server-close listener)))) - -(defun create-swank-server (port &key (announce #'simple-announce-function) - reuse-address - background - (close *close-swank-socket-after-setup*)) - (declare (ignore reuse-address background)) - (let* ((emacs (get-socket-stream port announce close)) - (slime-out (if *use-dedicated-output-stream* - (open-stream-to-emacs emacs) - (make-instance 'slime-output-stream))) - (slime-in (make-instance 'slime-input-stream)) - (slime-io (make-two-way-stream slime-in slime-out))) - (catch 'closed-connection - (loop (serve-request emacs slime-out slime-in slime-io))))) + (progn + (funcall announce (socket:socket-server-port socket)) + (socket:socket-wait socket 0) + (socket:socket-accept socket + :buffered nil + :element-type 'character + :external-format (ext:make-encoding + :charset 'charset:iso-8859-1 + :line-terminator :unix))) + (socket:socket-server-close socket)))) + +(defmethod make-fn-streams (input-fn output-fn) + (let* ((output (make-instance 'slime-output-stream + :output-fn output-fn)) + (input (make-instance 'slime-input-stream + :input-fn input-fn + :output-stream output))) + (values input output))) ;;; Swank functions From vsedach at common-lisp.net Mon Jan 12 05:06:22 2004 From: vsedach at common-lisp.net (Vladimir Sedach) Date: Mon, 12 Jan 2004 00:06:22 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26420 Modified Files: swank-backend.lisp Log Message: Fixed () arg in with-compilation-hooks. Date: Mon Jan 12 00:06:22 2004 Author: vsedach Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.13 slime/swank-backend.lisp:1.14 --- slime/swank-backend.lisp:1.13 Sun Jan 11 19:51:32 2004 +++ slime/swank-backend.lisp Mon Jan 12 00:06:22 2004 @@ -140,7 +140,8 @@ (:documentation "Call FUNC with hooks to trigger SLDB on compiler errors.")) -(defmacro with-compilation-hooks (() &body body) +(defmacro with-compilation-hooks ((&rest ignore) &body body) + (declare (ignore ignore)) `(call-with-compilation-hooks (lambda () (progn , at body)))) (defgeneric compile-string-for-emacs (string &key buffer position) From vsedach at common-lisp.net Mon Jan 12 05:14:13 2004 From: vsedach at common-lisp.net (Vladimir Sedach) Date: Mon, 12 Jan 2004 00:14:13 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29313 Modified Files: swank.lisp Log Message: Changed eval-region back to with-input-from-string style. For slime's purposes, read-from-string doesn't do the right thing with trailing whitespace, which is not easy to work around it. Date: Mon Jan 12 00:14:13 2004 Author: vsedach Index: slime/swank.lisp diff -u slime/swank.lisp:1.91 slime/swank.lisp:1.92 --- slime/swank.lisp:1.91 Sun Jan 11 23:31:31 2004 +++ slime/swank.lisp Mon Jan 12 00:14:13 2004 @@ -554,18 +554,20 @@ "Evaluate STRING and return the result. If PACKAGE-UPDATE-P is non-nil, and evaluation causes a package change, then send Emacs an update." - (let ((*package* *buffer-package*)) + (let ((*package* *buffer-package*) + - values) (unwind-protect - (do ((length (length string)) - (pos 0) - (- nil) - (return-value nil (multiple-value-list (eval -)))) - ((= pos length) (values return-value -)) - (multiple-value-setq (- pos) - (read-from-string string nil nil :start pos))) + (with-input-from-string (stream string) + (loop for form = (read stream nil stream) + until (eq form stream) + do (progn + (setq - form) + (setq values (multiple-value-list (eval form))) + (force-output)) + finally (return (values values -)))) (when (and package-update-p (not (eq *package* *buffer-package*))) - (send-to-emacs (list :new-package - (shortest-package-nickname *package*))))))) + (send-to-emacs + (list :new-package (shortest-package-nickname *package*))))))) (defun shortest-package-nickname (package) "Return the shortest nickname (or canonical name) of PACKAGE." From vsedach at common-lisp.net Mon Jan 12 05:22:11 2004 From: vsedach at common-lisp.net (Vladimir Sedach) Date: Mon, 12 Jan 2004 00:22:11 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25943 Modified Files: slime.el Log Message: Slime-repl-activate now goes to (point-max) at the end. This is the easiest kludge I could think of to fix the behavior of read-line (for example, on interactive restarts) which puts the pointer on the line preceeding the read-line prompt (after emacs has printed slime's prompt on the last line). Are there any situations where the slime prompt does not in fact get printed at the end of the buffer?? Date: Mon Jan 12 00:22:11 2004 Author: vsedach Index: slime/slime.el diff -u slime/slime.el:1.173 slime/slime.el:1.174 --- slime/slime.el:1.173 Sun Jan 11 19:50:33 2004 +++ slime/slime.el Mon Jan 12 00:22:11 2004 @@ -1954,7 +1954,8 @@ (unless (= (point-max) slime-repl-input-end-mark) (slime-mark-output-end) (slime-with-output-end-mark - (slime-repl-insert-prompt))))) + (slime-repl-insert-prompt)) + (goto-char (point-max))))) ;;!! is the prompt always the last line?? (defun slime-repl-current-input () "Return the current input as string. The input is the region from From vsedach at common-lisp.net Mon Jan 12 06:05:53 2004 From: vsedach at common-lisp.net (Vladimir Sedach) Date: Mon, 12 Jan 2004 01:05:53 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25597 Modified Files: swank-clisp.lisp Log Message: File compilation and loading somewhat work now. CLISP's compile-file returns some nutty number codes for warning-p and failure-p. Meaningful compilation messages still on to-do list. Date: Mon Jan 12 01:05:52 2004 Author: vsedach Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.5 slime/swank-clisp.lisp:1.6 --- slime/swank-clisp.lisp:1.5 Mon Jan 12 00:05:04 2004 +++ slime/swank-clisp.lisp Mon Jan 12 01:05:52 2004 @@ -341,10 +341,12 @@ `(let ((*error-output* (make-string-output-stream)) (*compile-verbose* t)) (multiple-value-prog1 - (compile-file , at args) + (compile-file , at args) + (handler-case (with-input-from-string - (*standard-input* (get-output-stream-string *error-output*)) - , at body)))) + (*standard-input* (get-output-stream-string *error-output*)) + , at body) + (sys::simple-end-of-file () nil))))) (defmethod call-with-compilation-hooks (function) (handler-bind ((compiler-condition #'handle-notification-condition)) @@ -366,10 +368,10 @@ (regexp:regexp-exec *compiler-note-line-regexp* line) (declare (ignore all)) (if head - (list (let ((*package* (find-package :keyword))) - (read-from-string (regexp:match-string line head))) - (read-from-string (regexp:match-string line tail))) - (list nil line)))) + (values (let ((*package* (find-package :keyword))) + (read-from-string (regexp:match-string line head))) + (read-from-string (regexp:match-string line tail))) + (values nil line)))) ;;; Ugly but essentially working. ;;; FIXME: I get all notes twice. @@ -380,27 +382,27 @@ (compile-file-frobbing-notes (filename) (read-line) ;"" (read-line) ;"Compiling file ..." - (loop - with condition - for (severity message) = (split-compiler-note-line (read-line)) - until (and (stringp message) (string= message "")) - if severity - do (when condition - (signal condition)) - (setq condition - (make-condition 'compiler-condition - :severity severity - :message "" - :location `(:location (:file ,filename) - (:line ,message)))) - else do (setf (message condition) - (format nil "~a~&~a" (message condition) message)) - finally (when condition - (signal condition)))) + (do ((condition) + (severity) + (comp-message)) + ((and (stringp comp-message) (string= comp-message "")) t) + (multiple-value-setq (severity comp-message) + (split-compiler-note-line (read-line))) + (when severity + (setq condition + (make-condition 'compiler-condition + :severity severity + :message "" + :location `(:location (:file ,filename) + (:line ,comp-message)))) + (setf (message condition) + (format nil "~a~&~a" (message condition) comp-message)) + (signal condition)))) (declare (ignore w-p)) - (cond ((and fasl-file (not f-p) load-p) - (load fasl-file)) - (t fasl-file))))) + (if (and (not (not f-p)) fasl-file load-p) +;;;!!! CLISP provides a fixnum for failure-p and warning-p for compile-file + (load fasl-file) + fasl-file)))) (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () From lgorrie at common-lisp.net Tue Jan 13 04:21:33 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 12 Jan 2004 23:21:33 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6560 Modified Files: swank.lisp Log Message: Updated for new network interface. Date: Mon Jan 12 23:21:33 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.92 slime/swank.lisp:1.93 --- slime/swank.lisp:1.92 Mon Jan 12 00:14:13 2004 +++ slime/swank.lisp Mon Jan 12 23:21:33 2004 @@ -115,15 +115,12 @@ ;;;; TCP Server -(defvar *start-swank-in-background* t) (defvar *close-swank-socket-after-setup* nil) -(defvar *use-dedicated-output-stream* t) +(defvar *use-dedicated-output-stream* #+lispworks nil #-lispworks t) ; FIXME (defun start-server (port-file) - (create-socket-server #'init-connection - :announce-fn (announce-server-port-fn port-file) - :port 0 - :loop nil)) + (accept-socket/run :announce-fn (announce-server-port-fn port-file) + :init-fn #'init-connection)) (defun announce-server-port-fn (file) (lambda (port) @@ -171,13 +168,7 @@ #'handle) (handle () (error "Protocol error: received input on dedicated output socket."))) - (create-socket-server #'init - :announce-fn #'announce - :loop nil - :accept-background nil - :handle-background t) - (assert (streamp stream)) - stream))) + (accept-socket/stream :announce-fn #'announce)))) (defun handle-request (connection) "Read and respond to one request from CONNECTION." From lgorrie at common-lisp.net Tue Jan 13 04:21:41 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 12 Jan 2004 23:21:41 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7223 Modified Files: swank-sbcl.lisp Log Message: Updated for new network interface. Date: Mon Jan 12 23:21:41 2004 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.46 slime/swank-sbcl.lisp:1.47 --- slime/swank-sbcl.lisp:1.46 Sun Jan 11 21:14:03 2004 +++ slime/swank-sbcl.lisp Mon Jan 12 23:21:41 2004 @@ -61,42 +61,29 @@ ;;; TCP Server - -(defmethod create-socket-server (init-fn &key announce-fn (port 0) - (accept-background t) - (handle-background t) - (loop t) - (reuse-address t)) +(defmethod accept-socket/stream (&key (port 0) announce-fn (reuse-address t)) (let ((socket (open-listener port reuse-address))) (funcall announce-fn (local-tcp-port socket)) - (setup-socket-accept socket init-fn accept-background handle-background loop))) - -(defun setup-socket-accept (socket init-fn accept-background handle-background loop) - (flet ((accept-client (&optional fd) - (declare (ignore fd)) - (accept-one-client socket init-fn handle-background (not loop)))) - (cond (accept-background (add-input-handler socket #'accept-client)) - (loop (loop (accept-client))) - (t (accept-client))))) + (let ((client-socket (accept socket))) + (sb-bsd-sockets:socket-close socket) + (make-socket-io-stream client-socket)))) -(defun accept-one-client (server-socket init-fn background close) - (let* ((client-socket (accept server-socket)) - (socket-stream (make-socket-io-stream client-socket)) - (handler-fn (funcall init-fn socket-stream))) - (when close - (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor - server-socket)) - (sb-bsd-sockets:socket-close server-socket)) - (if background - (add-input-handler client-socket - (lambda (fdes) - (declare (ignore fdes)) - (funcall handler-fn))) - (loop (funcall handler-fn))))) +(defmethod accept-socket/run (&key (port 0) announce-fn init-fn (reuse-address t)) + (let ((socket (open-listener port reuse-address))) + (funcall announce-fn (local-tcp-port socket)) + (add-input-handler socket (lambda () + (setup-client (accept socket) init-fn))))) +(defun setup-client (socket init-fn) + (let* ((socket-io (make-socket-io-stream socket)) + (handler-fn (funcall init-fn socket-io))) + (add-input-handler socket handler-fn))) + (defun add-input-handler (socket handler-fn) (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) - :input handler-fn)) + :input (lambda (fd) + (declare (ignore fd)) + (funcall handler-fn)))) (defun open-listener (port reuse-address) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket From lgorrie at common-lisp.net Tue Jan 13 04:22:07 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 12 Jan 2004 23:22:07 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8763 Modified Files: swank-cmucl.lisp Log Message: Updated for new network interface. Date: Mon Jan 12 23:22:07 2004 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.45 slime/swank-cmucl.lisp:1.46 --- slime/swank-cmucl.lisp:1.45 Sun Jan 11 19:52:25 2004 +++ slime/swank-cmucl.lisp Mon Jan 12 23:22:07 2004 @@ -10,36 +10,30 @@ ;;;; TCP server. -(defmethod create-socket-server (init-fn &key announce-fn (port 0) - (accept-background t) - (handle-background t) - (loop t) - (host "localhost")) - (let* ((ip (resolve-hostname host)) - (fd (ext:create-inet-listener port :stream :reuse-address t :host ip))) +(defvar *start-swank-in-background* t) + +(defmethod accept-socket/stream (&key (port 0) announce-fn (host "localhost")) + (let ((fd (ext:create-inet-listener port :stream + :reuse-address t + :host (resolve-hostname host)))) + (funcall announce-fn (local-tcp-port fd)) + (let ((client-fd (ext:accept-tcp-connection fd))) + (unix:unix-close fd) + (make-socket-io-stream client-fd)))) + +(defmethod accept-socket/run (&key (port 0) announce-fn init-fn (host "localhost")) + "Run in the background if *START-SWANK-IN-BACKGROUND* is true." + (let ((fd (ext:create-inet-listener port :stream + :reuse-address t + :host (resolve-hostname host)))) (funcall announce-fn (local-tcp-port fd)) - (setup-socket-accept fd init-fn accept-background handle-background loop))) + (add-input-handler fd (lambda () + (setup-client (ext:accept-tcp-connection fd) init-fn))))) -(defun setup-socket-accept (fd init-fn accept-background handle-background loop) - (flet ((accept-client (&optional (fd fd)) - (accept-one-client fd init-fn handle-background (not loop)))) - (cond (accept-background (add-input-handler fd #'accept-client)) - (loop (loop (accept-client))) - (t (accept-client))))) - -(defun accept-one-client (listen-fd init-fn background close) - (let* ((client-fd (ext:accept-tcp-connection listen-fd)) - (socket-stream (make-socket-io-stream client-fd)) - (handler-fn (funcall init-fn socket-stream))) - (when close - (sys:invalidate-descriptor listen-fd) - (unix:unix-close listen-fd)) - (if background - (add-input-handler client-fd - (lambda (fdes) - (declare (ignore fdes)) - (funcall handler-fn))) - (loop (funcall handler-fn))))) +(defun setup-client (fd init-fn) + (let* ((socket-io (make-socket-io-stream fd)) + (handler-fn (funcall init-fn socket-io))) + (add-input-handler fd handler-fn))) (defmethod make-fn-streams (input-fn output-fn) (let* ((output (make-slime-output-stream output-fn)) @@ -60,7 +54,10 @@ (ext:htonl address))) (defun add-input-handler (fd fn) - (system:add-fd-handler fd :input fn)) + (let ((callback (lambda (fd) + (declare (ignore fd)) + (funcall fn)))) + (system:add-fd-handler fd :input callback))) (defun make-socket-io-stream (fd) "Create a new input/output fd-stream for FD." From lgorrie at common-lisp.net Tue Jan 13 04:22:20 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 12 Jan 2004 23:22:20 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9665 Modified Files: swank-lispworks.lisp Log Message: Updated for new network interface. (accept-socket/stream): This function is currently broken, so LispWorks can't use the dedicated output channel at the moment. Date: Mon Jan 12 23:22:20 2004 Author: lgorrie Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.11 slime/swank-lispworks.lisp:1.12 --- slime/swank-lispworks.lisp:1.11 Sun Jan 11 23:30:27 2004 +++ slime/swank-lispworks.lisp Mon Jan 12 23:22:20 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.11 2004/01/12 04:30:27 lgorrie Exp $ +;;; $Id: swank-lispworks.lisp,v 1.12 2004/01/13 04:22:20 lgorrie Exp $ ;;; (in-package :swank) @@ -32,43 +32,39 @@ (defconstant +sigint+ 2) -(defmethod create-socket-server (init-fn &key announce-fn (port 0) - (accept-background t) - (handle-background t) - (loop t)) +(defmethod accept-socket/run (&key (port 0) announce-fn init-fn) (flet ((sentinel (socket condition) - (cond (socket - (let ((port (nth-value 1 (comm:get-socket-address socket)))) - (funcall announce-fn port))) - (t - (format *terminal-io* ";; Swank condition: ~A~%" - condition)))) - (accept (fd) - (accept-connection fd init-fn handle-background) - (unless loop (mp:process-kill mp:*current-process*)))) - (let ((server-process - (comm:start-up-server :announce #'sentinel :service port - :process-name "Swank server" - :function #'accept))) - (unless accept-background - (wait-process-death server-process))))) - -(defun accept-connection (fd init-fn background) - (let ((socket-io (make-instance 'comm:socket-stream - :socket fd - :direction :io - :element-type 'base-char))) - (sys:set-signal-handler +sigint+ #'sigint-handler) - (let* ((handler-fn (funcall init-fn socket-io)) - (loop-fn (lambda () (loop (funcall handler-fn))))) - (if background - (mp:process-run-function "Swank request handler" () loop-fn) - (funcall loop-fn))))) - -(defun wait-process-death (process) - (mp:process-wait "Letting Emacs connect" - (lambda () (not (mp:process-alive-p process))))) - + (when socket + (funcall announce-fn (local-tcp-port socket)))) + (accept (socket) + (let ((handler-fn (funcall init-fn (make-socket-stream socket)))) + (loop while t do (funcall handler-fn))))) + (comm:start-up-server :announce #'sentinel + :service port + :process-name "Swank server" + :function #'accept))) + +;;; FIXME: Broken. Why? +(defmethod accept-socket/stream (&key (port 0) announce-fn) + (let ((mbox (mp:make-mailbox))) + (flet ((init (stream) + (mp:mailbox-send mbox stream) + (mp:process-kill mp:*current-process*))) + (accept-socket/run :port port :announce-fn announce-fn :init-fn #'init) + (mp:mailbox-read mbox "Waiting for socket stream")))) + +(defun make-socket-stream (socket) + (make-instance 'comm:socket-stream + :socket socket + :direction :io + :element-type 'base-char)) + +(defun local-tcp-port (socket) + (nth-value 1 (comm:get-socket-address socket))) + +(defmethod emacs-connected () + ;; Set SIGINT handler on Swank request handler thread. + (sys:set-signal-handler +sigint+ #'sigint-handler)) (defun sigint-handler (&rest args) (declare (ignore args)) From lgorrie at common-lisp.net Tue Jan 13 04:23:12 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 12 Jan 2004 23:23:12 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13025 Modified Files: swank-clisp.lisp Log Message: Updated for new network interface but not tested! Probably slightly broken. Date: Mon Jan 12 23:23:12 2004 Author: lgorrie Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.6 slime/swank-clisp.lisp:1.7 --- slime/swank-clisp.lisp:1.6 Mon Jan 12 01:05:52 2004 +++ slime/swank-clisp.lisp Mon Jan 12 23:23:12 2004 @@ -25,7 +25,6 @@ (use-package "GRAY")) (setq *use-dedicated-output-stream* nil) -(setq *start-swank-in-background* nil) ;(setq *redirect-output* nil) #+linux @@ -79,15 +78,13 @@ ;;; TCP Server -(defmethod create-socket-server (init-fn &key announce-fn (port 0) - (accept-background nil) - (handle-background nil) - (loop nil) - (reuse-address nil)) - (declare (ignore loop reuse-address accept-background handle-background)) +(defmethod accept-socket/stream (&key (port 0) announce-fn) + (get-socket-stream port announce-fn)) + +(defmethod accept-socket/run (&key (port 0) announce-fn init-fn) (let* ((slime-stream (get-socket-stream port announce-fn)) (handler-fn (funcall init-fn slime-stream))) - (loop (funcall handler-fn)))) + (loop while t do (funcall handler-fn)))) (defun get-socket-stream (port announce) (let ((socket (socket:socket-server port))) From lgorrie at common-lisp.net Tue Jan 13 04:23:27 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 12 Jan 2004 23:23:27 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14816 Modified Files: swank-backend.lisp Log Message: (accept-socket/stream, accept-socket/run): New functions replacing the ancient (over 24 hours!) `create-socket-server'. This interface is much simpler. Date: Mon Jan 12 23:23:27 2004 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.14 slime/swank-backend.lisp:1.15 --- slime/swank-backend.lisp:1.14 Mon Jan 12 00:06:22 2004 +++ slime/swank-backend.lisp Mon Jan 12 23:23:27 2004 @@ -95,27 +95,26 @@ ;;;; TCP server -(defgeneric create-socket-server (init-fn &key announce-fn port - accept-background handle-background loop) +(defgeneric accept-socket/stream (&key port announce-fn) (:documentation - "Create a callback-driven TCP server. -Initially a TCP listen socket is opened, and then ANNOUNCE-FN is -called with its port number for its argument. + "Accept a single TCP connection and return an io stream for it. +PORT is the TCP port to use; if unspecified, any can be used. +If ANNOUNCE-FN is supplied then it is called as soon as the +server is listening, with the TCP port as its argument.")) -When a client connects, first a two-way stream is created for I/O -on the socket, and then INIT-FN is called with the stream for its -argument. INIT-FN returns another function, HANDLER-FN, to be -called with no arguments each time the stream becomes readable. - -If LOOP is true (the default), the server continues accepting -clients until CLOSE-SOCKET-SERVER is called. Otherwise the server -is closed after a single client has connected. +(defgeneric accept-socket/run (&key port announce-fn init-fn) + (:documentation + "Accept a single TCP connection and serve requests in a loop. +PORT and ANNOUNCE-FN are as for ACCEPT-SOCKET/STREAM. -If BACKGROUND-ACCEPT is true (the default), this function -immediately after creating the socket, and accepts connections -asynchronously. +INIT-FN is called when the first client is connected. Its +argument is the io stream connected to the socket. INIT-FN in +turn returns a function HANDLER-FN, which is then called each +time the socket becomes readable. -If BACKGROUND-HANDLE is true (the default), the... FIXME.")) +When this function returns is unspecified. It could loop to serve +the connection before returning, or it could return immediately +and handle the connection asynchronously.")) ;;; Base condition for networking errors. (define-condition network-error (error) ()) From lgorrie at common-lisp.net Tue Jan 13 04:23:38 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 12 Jan 2004 23:23:38 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14978 Modified Files: ChangeLog Log Message: Date: Mon Jan 12 23:23:38 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.199 slime/ChangeLog:1.200 --- slime/ChangeLog:1.199 Sun Jan 11 23:31:47 2004 +++ slime/ChangeLog Mon Jan 12 23:23:38 2004 @@ -1,3 +1,19 @@ +2004-01-13 Luke Gorrie + + * swank-clisp.lisp: Updated for new network interface but not + tested! Probably slightly broken. + + * swank-lispworks.lisp: Updated for new network interface. + (accept-socket/stream): This function is currently broken, so + LispWorks can't use the dedicated output channel at the moment. + + * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Updated for new + network interface. + + * swank-backend.lisp (accept-socket/stream, accept-socket/run): + New functions replacing the ancient (over 24 hours!) + `create-socket-server'. This interface is much simpler. + 2004-01-12 Luke Gorrie * swank-lispworks.lisp: Partially updated for new backend From heller at common-lisp.net Tue Jan 13 18:16:40 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 13:16:40 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv11616 Modified Files: swank-backend.lisp Log Message: (create-socket, local-port, close-socket, accept-connection, add-input-handler, spawn): New functions. (accept-socket/stream, accept-socket/run): Deleted. Date: Tue Jan 13 13:16:39 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.15 slime/swank-backend.lisp:1.16 --- slime/swank-backend.lisp:1.15 Mon Jan 12 23:23:27 2004 +++ slime/swank-backend.lisp Tue Jan 13 13:16:37 2004 @@ -95,26 +95,25 @@ ;;;; TCP server -(defgeneric accept-socket/stream (&key port announce-fn) - (:documentation - "Accept a single TCP connection and return an io stream for it. -PORT is the TCP port to use; if unspecified, any can be used. -If ANNOUNCE-FN is supplied then it is called as soon as the -server is listening, with the TCP port as its argument.")) +(defgeneric create-socket (port) + (:documentation "Create a listening TCP socket on port PORT.")) -(defgeneric accept-socket/run (&key port announce-fn init-fn) - (:documentation - "Accept a single TCP connection and serve requests in a loop. -PORT and ANNOUNCE-FN are as for ACCEPT-SOCKET/STREAM. +(defgeneric local-port (socket) + (:documentation "Return the local port number of SOCKET.")) -INIT-FN is called when the first client is connected. Its -argument is the io stream connected to the socket. INIT-FN in -turn returns a function HANDLER-FN, which is then called each -time the socket becomes readable. +(defgeneric close-socket (socket) + (:documentation "Close the socket SOCKET.")) -When this function returns is unspecified. It could loop to serve -the connection before returning, or it could return immediately -and handle the connection asynchronously.")) +(defgeneric accept-connection (socket) + (:documentation + "Accept a client connection on the listening socket SOCKET. Return +a stream for the new connection.")) + +(defgeneric add-input-handler (socket fn) + (:documentation "Call FN whenever SOCKET is readable.")) + +(defgeneric spawn (fn &key name) + (:documentation "Create a new process and call FN in the new process.")) ;;; Base condition for networking errors. (define-condition network-error (error) ()) From heller at common-lisp.net Tue Jan 13 18:17:48 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 13:17:48 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18817 Modified Files: swank.lisp Log Message: (start-server, open-dedicated-output-stream &etc): Use new socket functions. Date: Tue Jan 13 13:17:48 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.93 slime/swank.lisp:1.94 --- slime/swank.lisp:1.93 Mon Jan 12 23:21:33 2004 +++ slime/swank.lisp Tue Jan 13 13:17:48 2004 @@ -116,33 +116,34 @@ ;;;; TCP Server (defvar *close-swank-socket-after-setup* nil) -(defvar *use-dedicated-output-stream* #+lispworks nil #-lispworks t) ; FIXME +(defvar *use-dedicated-output-stream* t) (defun start-server (port-file) - (accept-socket/run :announce-fn (announce-server-port-fn port-file) - :init-fn #'init-connection)) - -(defun announce-server-port-fn (file) - (lambda (port) - (with-open-file (s file - :direction :output - :if-exists :overwrite - :if-does-not-exist :create) - (format s "~S~%" port)) - (simple-announce-function port))) + (let ((socket (create-socket 0))) + (announce-server-port port-file (local-port socket)) + (let ((client (accept-connection socket))) + (close-socket socket) + (let ((connection (init-connection client))) + (loop until (handle-request connection)))))) + +(defun announce-server-port (file port) + (with-open-file (s file + :direction :output + :if-exists :overwrite + :if-does-not-exist :create) + (format s "~S~%" port)) + (simple-announce-function port)) (defun init-connection (socket-io) (emacs-connected) - (let ((connection (create-connection socket-io))) - (lambda () - (handle-request connection)))) + (create-connection socket-io)) (defun create-connection (socket-io) (let ((output-fn (make-output-function socket-io)) (input-fn (lambda () (read-user-input-from-emacs socket-io)))) - (multiple-value-bind (user-in user-out) (make-fn-streams input-fn output-fn) - (let ((user-io (make-two-way-stream user-in user-out))) - (make-connection socket-io user-in user-out user-io))))) + (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) + (let ((io (make-two-way-stream in out))) + (make-connection socket-io in out io))))) (defun make-output-function (socket-io) (if *use-dedicated-output-stream* @@ -160,15 +161,10 @@ This is an optimized way for Lisp to deliver output to Emacs." ;; We start a server process, ask Emacs to connect to it, and then ;; return the socket's stream. - (let (stream) - (labels ((announce (port) - (send-to-emacs `(:open-dedicated-output-stream ,port) socket-io)) - (init (client-stream) - (setf stream client-stream) - #'handle) - (handle () - (error "Protocol error: received input on dedicated output socket."))) - (accept-socket/stream :announce-fn #'announce)))) + (let* ((socket (create-socket 0)) + (port (local-port socket))) + (send-to-emacs `(:open-dedicated-output-stream ,port) socket-io) + (accept-connection socket))) (defun handle-request (connection) "Read and respond to one request from CONNECTION." @@ -221,7 +217,7 @@ (defun current-socket-io () (connection.socket-io *dispatching-connection*)) -(defvar *log-events* nil) +(defparameter *log-events* nil) (defun log-event (format-string &rest args) "Write a message to *terminal-io* when *log-events* is non-nil. @@ -275,8 +271,8 @@ (without-interrupts* (lambda () (loop for position from 16 downto 0 by 8 - do (write-char (code-char (ldb (byte 8 position) length)) - output)) + do (write-char (code-char (ldb (byte 8 position) length)) + output)) (write-string string output) (terpri output) (force-output output)))))) From heller at common-lisp.net Tue Jan 13 18:20:05 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 13:20:05 -0500 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp slime/swank-lispworks.lisp slime/swank-clisp.lisp slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20718 Modified Files: swank-allegro.lisp swank-lispworks.lisp swank-clisp.lisp swank-cmucl.lisp swank-openmcl.lisp swank-sbcl.lisp Log Message: (create-socket, local-port, close-socket, accept-connection) (add-input-handler, spawn): Implement new socket interface. Date: Tue Jan 13 13:20:04 2004 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.5 slime/swank-allegro.lisp:1.6 --- slime/swank-allegro.lisp:1.5 Fri Jan 2 13:23:14 2004 +++ slime/swank-allegro.lisp Tue Jan 13 13:20:04 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.5 2004/01/02 18:23:14 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.6 2004/01/13 18:20:04 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -36,56 +36,22 @@ ;;; TCP Server -(setq *start-swank-in-background* nil) +(defmethod create-socket (port) + (socket:make-socket :connect :passive :local-port port :reuse-address t)) -(defun create-swank-server (port &key (reuse-address t) - (announce #'simple-announce-function) - (background *start-swank-in-background*) - (close *close-swank-socket-after-setup*)) - "Create a Swank TCP server on `port'." - (let ((server-socket (socket:make-socket :connect :passive :local-port port - :reuse-address reuse-address))) - (funcall announce (socket:local-port server-socket)) - (cond (background - (mp:process-run-function "Swank" #'accept-loop server-socket close)) - (t - (accept-loop server-socket close))))) - -(defun accept-loop (server-socket close) - (unwind-protect (cond (close (accept-one-client server-socket)) - (t (loop (accept-one-client server-socket)))) - (close server-socket))) - -(defun accept-one-client (server-socket) - (request-loop (socket:accept-connection server-socket :wait t))) - -(defun request-loop (stream) - (let* ((out (if *use-dedicated-output-stream* - (open-stream-to-emacs stream) - (make-instance 'slime-output-stream))) - (in (make-instance 'slime-input-stream)) - (io (make-two-way-stream in out))) - (do () ((serve-one-request stream out in io))))) - -(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime toplevel.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (close *emacs-io*) - (return-from serve-one-request t))))) - nil) - -(defun open-stream-to-emacs (*emacs-io*) - (let* ((listener (socket:make-socket :connect :passive :local-port 0 - :reuse-address t)) - (port (socket:local-port listener))) - (unwind-protect (progn - (eval-in-emacs `(slime-open-stream-to-lisp ,port)) - (socket:accept-connection listener :wait t)) - (close listener)))) +(defmethod local-port (socket) + (socket:local-port socket)) + +(defmethod close-socket (socket) + (close socket)) + +(defmethod accept-connection (socket) + (socket:accept-connection socket :wait t)) + +(defmethod spawn (fn &key name) + (mp:process-run-function name fn)) + +;;; (defmethod arglist-string (fname) (declare (type string fname)) Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.12 slime/swank-lispworks.lisp:1.13 --- slime/swank-lispworks.lisp:1.12 Mon Jan 12 23:22:20 2004 +++ slime/swank-lispworks.lisp Tue Jan 13 13:20:04 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.12 2004/01/13 04:22:20 lgorrie Exp $ +;;; $Id: swank-lispworks.lisp,v 1.13 2004/01/13 18:20:04 heller Exp $ ;;; (in-package :swank) @@ -32,35 +32,37 @@ (defconstant +sigint+ 2) -(defmethod accept-socket/run (&key (port 0) announce-fn init-fn) - (flet ((sentinel (socket condition) - (when socket - (funcall announce-fn (local-tcp-port socket)))) - (accept (socket) - (let ((handler-fn (funcall init-fn (make-socket-stream socket)))) - (loop while t do (funcall handler-fn))))) - (comm:start-up-server :announce #'sentinel - :service port - :process-name "Swank server" - :function #'accept))) - -;;; FIXME: Broken. Why? -(defmethod accept-socket/stream (&key (port 0) announce-fn) - (let ((mbox (mp:make-mailbox))) - (flet ((init (stream) - (mp:mailbox-send mbox stream) - (mp:process-kill mp:*current-process*))) - (accept-socket/run :port port :announce-fn announce-fn :init-fn #'init) - (mp:mailbox-read mbox "Waiting for socket stream")))) - -(defun make-socket-stream (socket) - (make-instance 'comm:socket-stream - :socket socket - :direction :io - :element-type 'base-char)) +;;; TCP server -(defun local-tcp-port (socket) - (nth-value 1 (comm:get-socket-address socket))) +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defmethod create-socket (port) + (multiple-value-bind (socket where errno) + (comm::create-tcp-socket-for-service port :address "localhost") + (cond (socket socket) + (t (error 'network-error "asdf ~A") + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno))))) + +(defmethod local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defmethod close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defmethod accept-connection (socket) + (let ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (make-instance 'comm:socket-stream :socket fd :direction :io + :element-type 'base-char))) + +(defmethod spawn (fn &key name) + (mp:process-run-function name () fn)) (defmethod emacs-connected () ;; Set SIGINT handler on Swank request handler thread. @@ -70,14 +72,7 @@ (declare (ignore args)) (invoke-debugger "SIGINT")) -(defmethod make-fn-streams (input-fn output-fn) - (let* ((output (make-instance 'slime-output-stream - :output-fn output-fn)) - (input (make-instance 'slime-input-stream - :input-fn input-fn - :output-stream output))) - (values input output))) - +;;; (defslimefun getpid () "Return the process ID of this superior Lisp." Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.7 slime/swank-clisp.lisp:1.8 --- slime/swank-clisp.lisp:1.7 Mon Jan 12 23:23:12 2004 +++ slime/swank-clisp.lisp Tue Jan 13 13:20:04 2004 @@ -43,70 +43,30 @@ (defun without-interrupts* (fun) (without-interrupts (funcall fun))) -#+linux (defslimefun getpid () (linux::getpid)) #+unix (defslimefun getpid () (system::program-id)) #+win32 (defslimefun getpid () (or (system::getenv "PID") -1)) ;; the above is likely broken; we need windows NT users! -;;; Gray streams - -;; From swank-gray.lisp. - -(defclass slime-input-stream (fundamental-character-input-stream) - ((buffer :initform "") (index :initform 0))) - -;; We have to define an additional method for the sake of the C -;; function listen_char (see src/stream.d), on which SYS::READ-FORM -;; depends. - -;; We could make do with either of the two methods below. - -(defmethod stream-read-char-no-hang ((s slime-input-stream)) - (with-slots (buffer index) s - (when (< index (length buffer)) - (prog1 (aref buffer index) (incf index))))) - -;; This CLISP extension is what listen_char actually calls. The -;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit -;; more efficient to define it directly. - -(defmethod stream-read-char-will-hang-p ((s slime-input-stream)) - (with-slots (buffer index) s - (= index (length buffer)))) - - ;;; TCP Server -(defmethod accept-socket/stream (&key (port 0) announce-fn) - (get-socket-stream port announce-fn)) +(defmethod create-socket (port) + (socket:socket-server port)) -(defmethod accept-socket/run (&key (port 0) announce-fn init-fn) - (let* ((slime-stream (get-socket-stream port announce-fn)) - (handler-fn (funcall init-fn slime-stream))) - (loop while t do (funcall handler-fn)))) +(defmethod local-port (socket) + (socket:socket-server-port socket)) -(defun get-socket-stream (port announce) - (let ((socket (socket:socket-server port))) - (unwind-protect - (progn - (funcall announce (socket:socket-server-port socket)) - (socket:socket-wait socket 0) - (socket:socket-accept socket - :buffered nil - :element-type 'character - :external-format (ext:make-encoding - :charset 'charset:iso-8859-1 - :line-terminator :unix))) - (socket:socket-server-close socket)))) +(defmethod close-socket (socket) + (socket:socket-server-close socket)) -(defmethod make-fn-streams (input-fn output-fn) - (let* ((output (make-instance 'slime-output-stream - :output-fn output-fn)) - (input (make-instance 'slime-input-stream - :input-fn input-fn - :output-stream output))) - (values input output))) +(defmethod accept-connection (socket) + (socket:socket-wait socket) + (socket:socket-accept socket + :buffered nil ;; XXX should be t + :element-type 'character + :external-format (ext:make-encoding + :charset 'charset:iso-8859-1 + :line-terminator :unix))) ;;; Swank functions Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.46 slime/swank-cmucl.lisp:1.47 --- slime/swank-cmucl.lisp:1.46 Mon Jan 12 23:22:07 2004 +++ slime/swank-cmucl.lisp Tue Jan 13 13:20:04 2004 @@ -10,30 +10,25 @@ ;;;; TCP server. -(defvar *start-swank-in-background* t) - -(defmethod accept-socket/stream (&key (port 0) announce-fn (host "localhost")) - (let ((fd (ext:create-inet-listener port :stream - :reuse-address t - :host (resolve-hostname host)))) - (funcall announce-fn (local-tcp-port fd)) - (let ((client-fd (ext:accept-tcp-connection fd))) - (unix:unix-close fd) - (make-socket-io-stream client-fd)))) - -(defmethod accept-socket/run (&key (port 0) announce-fn init-fn (host "localhost")) - "Run in the background if *START-SWANK-IN-BACKGROUND* is true." - (let ((fd (ext:create-inet-listener port :stream - :reuse-address t - :host (resolve-hostname host)))) - (funcall announce-fn (local-tcp-port fd)) - (add-input-handler fd (lambda () - (setup-client (ext:accept-tcp-connection fd) init-fn))))) - -(defun setup-client (fd init-fn) - (let* ((socket-io (make-socket-io-stream fd)) - (handler-fn (funcall init-fn socket-io))) - (add-input-handler fd handler-fn))) +(defmethod create-socket (port) + (ext:create-inet-listener port :stream + :reuse-address t + :host (resolve-hostname "localhost"))) + +(defmethod local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defmethod close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defmethod accept-connection (socket) + (make-socket-io-stream (ext:accept-tcp-connection socket))) + +(defmethod add-input-handler (socket fn) + (flet ((callback (fd) + (declare (ignore fd)) + (funcall fn))) + (system:add-fd-handler (socket-fd socket) :input #'callback))) (defmethod make-fn-streams (input-fn output-fn) (let* ((output (make-slime-output-stream output-fn)) @@ -43,21 +38,17 @@ ;;; ;;;;; Socket helpers. -(defun local-tcp-port (fd) - "Return the TCP port of the socket represented by FD." - (nth-value 1 (ext::get-socket-host-and-port fd))) +(defun socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) (defun resolve-hostname (hostname) "Return the IP address of HOSTNAME as an integer." (let* ((hostent (ext:lookup-host-entry hostname)) (address (car (ext:host-entry-addr-list hostent)))) (ext:htonl address))) - -(defun add-input-handler (fd fn) - (let ((callback (lambda (fd) - (declare (ignore fd)) - (funcall fn)))) - (system:add-fd-handler fd :input callback))) (defun make-socket-io-stream (fd) "Create a new input/output fd-stream for FD." Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.43 slime/swank-openmcl.lisp:1.44 --- slime/swank-openmcl.lisp:1.43 Fri Jan 2 13:23:14 2004 +++ slime/swank-openmcl.lisp Tue Jan 13 13:20:04 2004 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.43 2004/01/02 18:23:14 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.44 2004/01/13 18:20:04 heller Exp $ ;;; ;;; @@ -75,26 +75,22 @@ ;;; TCP Server -;; In OpenMCL, the Swank backend runs in a separate thread and simply -;; blocks on its TCP port while waiting for forms to evaluate. +(defmethod create-socket (port) + (ccl:make-socket :connect :passive :local-port port :reuse-address t)) -(defun create-swank-server (port &key (reuse-address t) - (announce #'simple-announce-function) - (background *start-swank-in-background*) - (close *close-swank-socket-after-setup*)) - "Create a Swank TCP server on `port'." - (let ((server-socket (ccl:make-socket :connect :passive :local-port port - :reuse-address reuse-address))) - (funcall announce (ccl:local-port server-socket)) - (cond (background - (let ((swank (ccl:process-run-function - "Swank" #'accept-loop server-socket close))) - ;; tell openmcl which process you want to be interrupted when - ;; sigint is received - (setq ccl::*interactive-abort-process* swank) - swank)) - (t - (accept-loop server-socket close))))) +(defmethod local-port (socket) + (ccl:local-port socket)) + +(defmethod close-socket (socket) + (close socket)) + +(defmethod accept-connection (socket) + (ccl:accept-connection socket :wait t)) + +(defmethod spawn (fn &key name) + (ccl:process-run-function name fn)) + +;;; (let ((ccl::*warn-if-redefine-kernel* nil)) (defun ccl::force-break-in-listener (p) @@ -125,7 +121,6 @@ (eq ccl::*current-process* ccl::*interactive-abort-process*)) (apply 'break-in-sldb ccl::arglist) (:do-it)) :when :around :name sldb-break)) - (defun break-in-sldb (&optional string &rest args) (let ((c (make-condition 'simple-condition @@ -146,44 +141,6 @@ (restart-case (invoke-debugger c) (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t)) ))) - -(defun accept-loop (server-socket close) - (unwind-protect (cond (close (accept-one-client server-socket)) - (t (loop (accept-one-client server-socket)))) - (close server-socket))) - -(defun accept-one-client (server-socket) - (request-loop (ccl:accept-connection server-socket :wait t))) - -(defun request-loop (stream) - (let* ((out (if *use-dedicated-output-stream* - (open-stream-to-emacs stream) - (make-instance 'slime-output-stream))) - (in (make-instance 'slime-input-stream)) - (io (make-two-way-stream in out))) - (push out ccl::*auto-flush-streams*) - (unwind-protect (do () ((serve-one-request stream out in io))) - (setq ccl::*auto-flush-streams* (remove out ccl::*auto-flush-streams*))))) - -(defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*) - (catch 'slime-toplevel - (with-simple-restart (abort "Return to Slime toplevel.") - (handler-case (read-from-emacs) - (slime-read-error (e) - (when *swank-debug-p* - (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (close *emacs-io*) - (return-from serve-one-request t))))) - nil) - -(defun open-stream-to-emacs (*emacs-io*) - (let* ((listener (ccl:make-socket :connect :passive :local-port 0 - :reuse-address t)) - (port (ccl:local-port listener))) - (unwind-protect (progn - (eval-in-emacs `(slime-open-stream-to-lisp ,port)) - (ccl:accept-connection listener :wait t)) - (close listener)))) ;;; Evaluation Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.47 slime/swank-sbcl.lisp:1.48 --- slime/swank-sbcl.lisp:1.47 Mon Jan 12 23:21:41 2004 +++ slime/swank-sbcl.lisp Tue Jan 13 13:20:04 2004 @@ -61,64 +61,47 @@ ;;; TCP Server -(defmethod accept-socket/stream (&key (port 0) announce-fn (reuse-address t)) - (let ((socket (open-listener port reuse-address))) - (funcall announce-fn (local-tcp-port socket)) - (let ((client-socket (accept socket))) - (sb-bsd-sockets:socket-close socket) - (make-socket-io-stream client-socket)))) - -(defmethod accept-socket/run (&key (port 0) announce-fn init-fn (reuse-address t)) - (let ((socket (open-listener port reuse-address))) - (funcall announce-fn (local-tcp-port socket)) - (add-input-handler socket (lambda () - (setup-client (accept socket) init-fn))))) - -(defun setup-client (socket init-fn) - (let* ((socket-io (make-socket-io-stream socket)) - (handler-fn (funcall init-fn socket-io))) - (add-input-handler socket handler-fn))) - -(defun add-input-handler (socket handler-fn) - (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) - :input (lambda (fd) - (declare (ignore fd)) - (funcall handler-fn)))) - -(defun open-listener (port reuse-address) +(defmethod create-socket (port) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) - (when reuse-address - (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) - ;;(setf (sb-bsd-sockets:non-blocking-mode socket) t) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket #(127 0 0 1) port) (sb-bsd-sockets:socket-listen socket 5) socket)) -(defun local-tcp-port (socket) +(defmethod local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) +(defmethod close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defmethod accept-connection (socket) + (make-socket-io-stream (accept socket))) + +(defmethod add-input-handler (socket fn) + (sb-sys:add-fd-handler (socket-fd socket) + :input (lambda (fd) + (declare (ignore fd)) + (funcall fn)))) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + (defun make-socket-io-stream (socket) (sb-bsd-sockets:socket-make-stream socket :output t :input t :element-type 'base-char)) - (defun accept (socket) "Like socket-accept, but retry on EAGAIN." (loop (handler-case (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) - -(defmethod make-fn-streams (input-fn output-fn) - (let* ((output (make-instance 'slime-output-stream - :output-fn output-fn)) - (input (make-instance 'slime-input-stream - :input-fn input-fn - :output-stream output))) - (values input output))) ;;; Utilities From heller at common-lisp.net Tue Jan 13 18:21:48 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 13:21:48 -0500 Subject: [slime-cvs] CVS update: slime/swank-gray.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17569 Modified Files: swank-gray.lisp Log Message: (make-fn-streams): New function. (stream-read-char-no-hang, stream-read-char-will-hang-p): Moved to here from swank-clisp.lisp. Date: Tue Jan 13 13:21:48 2004 Author: heller Index: slime/swank-gray.lisp diff -u slime/swank-gray.lisp:1.2 slime/swank-gray.lisp:1.3 --- slime/swank-gray.lisp:1.2 Sun Jan 11 21:14:17 2004 +++ slime/swank-gray.lisp Tue Jan 13 13:21:48 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-gray.lisp,v 1.2 2004/01/12 02:14:17 lgorrie Exp $ +;;; $Id: swank-gray.lisp,v 1.3 2004/01/13 18:21:48 heller Exp $ ;;; (in-package :swank) @@ -79,3 +79,34 @@ (defmethod stream-line-length ((s slime-input-stream)) 75) + +;;; CLISP extensions + +;; We have to define an additional method for the sake of the C +;; function listen_char (see src/stream.d), on which SYS::READ-FORM +;; depends. + +;; We could make do with either of the two methods below. + +(defmethod stream-read-char-no-hang ((s slime-input-stream)) + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))) + +;; This CLISP extension is what listen_char actually calls. The +;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit +;; more efficient to define it directly. + +(defmethod stream-read-char-will-hang-p ((s slime-input-stream)) + (with-slots (buffer index) s + (= index (length buffer)))) + + +;;; +(defmethod make-fn-streams (input-fn output-fn) + (let* ((output (make-instance 'slime-output-stream + :output-fn output-fn)) + (input (make-instance 'slime-input-stream + :input-fn input-fn + :output-stream output))) + (values input output))) \ No newline at end of file From heller at common-lisp.net Tue Jan 13 18:28:49 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 13:28:49 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25692 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jan 13 13:28:49 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.200 slime/ChangeLog:1.201 --- slime/ChangeLog:1.200 Mon Jan 12 23:23:38 2004 +++ slime/ChangeLog Tue Jan 13 13:28:49 2004 @@ -1,3 +1,28 @@ +2004-01-13 Helmut Eller + + New more direct socket interface. The new interface is closer to + the functions provided by the implementations. For Lispworks we + use some non-exported functions to get a sane interface. The + interface also includes add-input-handler and a spawn function + (not used yet). The idea is that most of the logic can be shared + between similar backends. + + * swank-gray.lisp (make-fn-streams): New function. + (stream-read-char-no-hang, stream-read-char-will-hang-p): Moved to + here from swank-clisp.lisp. + + * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, + swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp: + (create-socket, local-port, close-socket, accept-connection) + (add-input-handler, spawn): Implement new socket interface. + + * swank.lisp (start-server, open-dedicated-output-stream &etc): + Use new socket functions. + + * swank-backend.lisp (create-socket, local-port, close-socket) + (accept-connection, add-input-handler, spawn): New functions. + (accept-socket/stream, accept-socket/run): Deleted. + 2004-01-13 Luke Gorrie * swank-clisp.lisp: Updated for new network interface but not From heller at common-lisp.net Tue Jan 13 19:27:24 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 14:27:24 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8242 Modified Files: swank-clisp.lisp Log Message: (accept-connection): Remove superfluous call to socket-wait. Date: Tue Jan 13 14:27:24 2004 Author: heller Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.8 slime/swank-clisp.lisp:1.9 --- slime/swank-clisp.lisp:1.8 Tue Jan 13 13:20:04 2004 +++ slime/swank-clisp.lisp Tue Jan 13 14:27:24 2004 @@ -60,7 +60,6 @@ (socket:socket-server-close socket)) (defmethod accept-connection (socket) - (socket:socket-wait socket) (socket:socket-accept socket :buffered nil ;; XXX should be t :element-type 'character From heller at common-lisp.net Tue Jan 13 19:28:10 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 14:28:10 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13984 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jan 13 14:28:10 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.201 slime/ChangeLog:1.202 --- slime/ChangeLog:1.201 Tue Jan 13 13:28:49 2004 +++ slime/ChangeLog Tue Jan 13 14:28:10 2004 @@ -1,5 +1,8 @@ 2004-01-13 Helmut Eller + * swank-clisp.lisp (accept-connection): Remove superfluous call to + socket-wait. + New more direct socket interface. The new interface is closer to the functions provided by the implementations. For Lispworks we use some non-exported functions to get a sane interface. The From heller at common-lisp.net Tue Jan 13 22:48:25 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 17:48:25 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30390 Modified Files: swank-cmucl.lisp Log Message: (*swank-in-background*): Set to :fd-handler. Date: Tue Jan 13 17:48:25 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.47 slime/swank-cmucl.lisp:1.48 --- slime/swank-cmucl.lisp:1.47 Tue Jan 13 13:20:04 2004 +++ slime/swank-cmucl.lisp Tue Jan 13 17:48:25 2004 @@ -10,6 +10,8 @@ ;;;; TCP server. +(setq *swank-in-background* :fd-handler) + (defmethod create-socket (port) (ext:create-inet-listener port :stream :reuse-address t From heller at common-lisp.net Tue Jan 13 22:49:35 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 17:49:35 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15040 Modified Files: swank.lisp Log Message: (*swank-in-background*): New variable. (start-server): Start swank in background, depending on *swank-in-background*. Date: Tue Jan 13 17:49:34 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.94 slime/swank.lisp:1.95 --- slime/swank.lisp:1.94 Tue Jan 13 13:17:48 2004 +++ slime/swank.lisp Tue Jan 13 17:49:34 2004 @@ -117,14 +117,26 @@ (defvar *close-swank-socket-after-setup* nil) (defvar *use-dedicated-output-stream* t) +(defvar *swank-in-background* nil) (defun start-server (port-file) (let ((socket (create-socket 0))) (announce-server-port port-file (local-port socket)) (let ((client (accept-connection socket))) (close-socket socket) - (let ((connection (init-connection client))) - (loop until (handle-request connection)))))) + (let ((connection (create-connection client))) + (ecase *swank-in-background* + (:fd-handler + (emacs-connected) + (add-input-handler client (lambda () (handle-request connection)))) + (:spawn + (spawn (lambda () + (emacs-connected) + (loop until (handle-request connection))) + :name "Swank")) + ((nil) + (emacs-connected) + (loop until (handle-request connection)))))))) (defun announce-server-port (file port) (with-open-file (s file @@ -133,10 +145,6 @@ :if-does-not-exist :create) (format s "~S~%" port)) (simple-announce-function port)) - -(defun init-connection (socket-io) - (emacs-connected) - (create-connection socket-io)) (defun create-connection (socket-io) (let ((output-fn (make-output-function socket-io)) From heller at common-lisp.net Tue Jan 13 22:50:09 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 17:50:09 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19029 Modified Files: swank-sbcl.lisp Log Message: (*swank-in-background*): Set to :fd-handler. Date: Tue Jan 13 17:50:09 2004 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.48 slime/swank-sbcl.lisp:1.49 --- slime/swank-sbcl.lisp:1.48 Tue Jan 13 13:20:04 2004 +++ slime/swank-sbcl.lisp Tue Jan 13 17:50:09 2004 @@ -61,6 +61,8 @@ ;;; TCP Server +(setq *swank-in-background* :fd-handler) + (defmethod create-socket (port) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream From heller at common-lisp.net Tue Jan 13 22:51:07 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 17:51:07 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23872 Modified Files: swank-openmcl.lisp Log Message: (*swank-in-background*): Set to :spawn. (emacs-connected): Set the ccl::*interactive-abort-process*. Date: Tue Jan 13 17:51:07 2004 Author: heller Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.44 slime/swank-openmcl.lisp:1.45 --- slime/swank-openmcl.lisp:1.44 Tue Jan 13 13:20:04 2004 +++ slime/swank-openmcl.lisp Tue Jan 13 17:51:07 2004 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.44 2004/01/13 18:20:04 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.45 2004/01/13 22:51:07 heller Exp $ ;;; ;;; @@ -75,6 +75,8 @@ ;;; TCP Server +(setq *swank-in-background* :spawn) + (defmethod create-socket (port) (ccl:make-socket :connect :passive :local-port port :reuse-address t)) @@ -89,6 +91,9 @@ (defmethod spawn (fn &key name) (ccl:process-run-function name fn)) + +(defmethod emacs-connected () + (setq ccl::*interactive-abort-process* ccl::*current-process*) ;;; From heller at common-lisp.net Tue Jan 13 22:51:57 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 17:51:57 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25957 Modified Files: swank-lispworks.lisp Log Message: (create-socket): Fix condition message. Date: Tue Jan 13 17:51:57 2004 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.13 slime/swank-lispworks.lisp:1.14 --- slime/swank-lispworks.lisp:1.13 Tue Jan 13 13:20:04 2004 +++ slime/swank-lispworks.lisp Tue Jan 13 17:51:56 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.13 2004/01/13 18:20:04 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.14 2004/01/13 22:51:56 heller Exp $ ;;; (in-package :swank) @@ -43,11 +43,11 @@ (multiple-value-bind (socket where errno) (comm::create-tcp-socket-for-service port :address "localhost") (cond (socket socket) - (t (error 'network-error "asdf ~A") + (t (error 'network-error :format-control "~A failed: ~A (~D)" :format-arguments (list where (list #+unix (lw:get-unix-error errno)) - errno))))) + errno)))))) (defmethod local-port (socket) (nth-value 1 (comm:get-socket-address (socket-fd socket)))) From heller at common-lisp.net Tue Jan 13 22:56:10 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 17:56:10 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19882 Modified Files: slime.el Log Message: (slime-input-complete-p): Tolerate extra close parens. (slime-idle-state): Don't active the repl. (slime-insert-transcript-delimiter): Insert output before prompt. (slime-open-stream-to-lisp): Initialize the process-buffer with the connection buffer. (slime-repl-activate): Deleted. (slime-repl-eval-string, slime-repl-show-result, slime-repl-show-abort): Better handling of abortion. (slime-compile-file): Insert output before prompt. Date: Tue Jan 13 17:56:10 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.174 slime/slime.el:1.175 --- slime/slime.el:1.174 Mon Jan 12 00:22:11 2004 +++ slime/slime.el Tue Jan 13 17:56:09 2004 @@ -348,18 +348,20 @@ (defun slime-input-complete-p (start end) "Return t if the region from START to END contains a complete sexp." - (ignore-errors - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - ;; Keep stepping over blanks and sexps until the end of buffer - ;; is reached or an error occurs - (loop do (or (skip-chars-forward " \t\r\n") - (looking-at ")")) ; tollerate extra close parens - until (eobp) - do (forward-sexp)) - t)))) + (save-excursion + (goto-char start) + (cond ((looking-at "\\s *(") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) (defun inferior-slime-input-complete-p () "Return true if the input is complete in the inferior lisp buffer." @@ -1531,8 +1533,7 @@ (slime-defstate slime-idle-state () "Idle state. The user may make a request, or Lisp may invoke the debugger." ((activate) - (assert (= (sldb-level) 0)) - (slime-repl-activate)) + (assert (= (sldb-level) 0))) ((:debug level condition restarts frames) (slime-push-state (slime-debugging-state level condition restarts frames @@ -1779,22 +1780,22 @@ (set-marker (symbol-value markname) (point))) (set-marker-insertion-type slime-repl-input-end-mark t) (set-marker-insertion-type slime-output-end t) + (set-marker-insertion-type slime-repl-prompt-start-mark t) (slime-repl-insert-prompt) (current-buffer))))) (defun slime-insert-transcript-delimiter (string) (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (slime-mark-input-end) - (slime-insert-propertized - '(slime-transcript-delimiter t) - ";;;; " - (subst-char-in-string ?\n ?\ - (substring string 0 - (min 60 (length string)))) - " ...\n") - (slime-mark-output-start))) - + (save-excursion + (goto-char slime-repl-prompt-start-mark) + (slime-insert-propertized + '(slime-transcript-delimiter t) + (if (bolp) "" "\n") + ";;;; " (subst-char-in-string ?\n ?\ + (substring string 0 + (min 60 (length string)))) + " ...\n") + (slime-mark-output-start)))) (defvar slime-show-last-output-function 'slime-maybe-display-output-buffer @@ -1828,8 +1829,6 @@ "Display the output buffer and scroll to bottom." (with-current-buffer (slime-output-buffer) (goto-char (point-max)) - (slime-mark-input-end) - (slime-mark-output-start) (display-buffer (current-buffer) t))) (defmacro slime-with-output-end-mark (&rest body) @@ -1859,7 +1858,8 @@ (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" - nil + (slime-with-connection-buffer () + (current-buffer)) "localhost" port))) (set-process-filter stream 'slime-output-filter) stream)) @@ -1930,7 +1930,6 @@ (defun slime-repl-insert-prompt () (let ((start (point))) (unless (bolp) (insert "\n")) - (set-marker slime-repl-prompt-start-mark (point) (current-buffer)) (slime-propertize-region '(face font-lock-keyword-face read-only t @@ -1942,21 +1941,9 @@ start-open t end-open t) (insert (slime-lisp-package) "> ")) (set-marker slime-output-end start) + (set-marker slime-repl-prompt-start-mark (1+ start) (current-buffer)) (slime-mark-input-start))) -(defun slime-repl-activate () - ;; We use the input-end-mark to decide if we should insert a prompt - ;; or not. We don't print a prompt if input-end-mark at the of the - ;; buffer. This situation occurs when we are after a slime-space - ;; command. slime-mark-input-end sets the input-end-mark to some - ;; position before the end and triggers printing of the prompt. - (with-current-buffer (slime-output-buffer) - (unless (= (point-max) slime-repl-input-end-mark) - (slime-mark-output-end) - (slime-with-output-end-mark - (slime-repl-insert-prompt)) - (goto-char (point-max))))) ;;!! is the prompt always the last line?? - (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." @@ -1977,9 +1964,10 @@ (setq slime-repl-input-history-position -1)) (defun slime-repl-eval-string (string) - (slime-eval-async `(swank:listener-eval ,string) - (slime-lisp-package) - (slime-repl-show-result-continutation))) + (slime-rex () + ((list 'swank:listener-eval string) (slime-lisp-package)) + ((:ok result) (slime-repl-show-result result)) + ((:abort) (slime-repl-show-abort)))) (defun slime-repl-send-string (string) (slime-repl-add-to-input-history string) @@ -1987,17 +1975,26 @@ (slime-idle-state (slime-repl-eval-string string)) (slime-read-string-state (slime-repl-return-string string)))) -(defun slime-repl-show-result-continutation () - ;; This is called _after_ the idle state is activated. This means - ;; the prompt is already printed. - (lambda (result) - (with-current-buffer (slime-output-buffer) - (save-excursion - (goto-char slime-repl-prompt-start-mark) - (let ((start (point))) - (insert result "\n") - (set-marker slime-output-end start)))))) +(defun slime-repl-show-result (result) + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (let ((start (point))) + (insert result "\n") + (slime-repl-insert-prompt) + (set-marker slime-output-end start)))) +(defun slime-repl-show-abort () + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (unless (bolp) (insert "\n")) + (insert "; Evaluation aborted\n")) + (slime-rex () + ((list 'swank:listener-eval "") nil) + ((:ok result) (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (slime-repl-insert-prompt)) + (goto-char (point-max))))))) + (defun slime-mark-input-start () (set-marker slime-repl-last-input-start-mark (marker-position slime-repl-input-start-mark)) @@ -2330,6 +2327,8 @@ (unless (eq major-mode 'lisp-mode) (error "Only valid in lisp-mode")) (save-some-buffers) + (slime-insert-transcript-delimiter + (format "Compile file %s" (buffer-file-name))) (slime-display-output-buffer) (slime-eval-async `(swank:swank-compile-file ,(buffer-file-name) ,(if load t nil)) From heller at common-lisp.net Tue Jan 13 23:04:00 2004 From: heller at common-lisp.net (Helmut Eller) Date: Tue, 13 Jan 2004 18:04:00 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6274 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jan 13 18:03:59 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.202 slime/ChangeLog:1.203 --- slime/ChangeLog:1.202 Tue Jan 13 14:28:10 2004 +++ slime/ChangeLog Tue Jan 13 18:03:59 2004 @@ -1,5 +1,27 @@ 2004-01-13 Helmut Eller + * slime.el (slime-input-complete-p): Tolerate extra close parens. + (slime-idle-state): Don't active the repl. + (slime-insert-transcript-delimiter): Insert output before prompt. + (slime-open-stream-to-lisp): Initialize the process-buffer with + the connection buffer. + (slime-repl-activate): Deleted. + (slime-repl-eval-string, slime-repl-show-result) + (slime-repl-show-abort): Better handling of abortion. + (slime-compile-file): Insert output before prompt. + + * swank-lispworks.lisp (create-socket): Fix condition message. + + * swank-openmcl.lisp (*swank-in-background*): Set to :spawn. + (emacs-connected): Initialize ccl::*interactive-abort-process*. + + * swank.lisp (*swank-in-background*): New variable. + (start-server): Start swank in background, depending on + *swank-in-background*. + + * swank-cmucl.lisp, swank-sbcl.lisp (*swank-in-background*): Set + to :fd-handler. + * swank-clisp.lisp (accept-connection): Remove superfluous call to socket-wait. From lgorrie at common-lisp.net Wed Jan 14 06:53:53 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 14 Jan 2004 01:53:53 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12842 Modified Files: swank-openmcl.lisp Log Message: (emacs-connected): Typo fix (missing close-paren). Date: Wed Jan 14 01:53:53 2004 Author: lgorrie Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.45 slime/swank-openmcl.lisp:1.46 --- slime/swank-openmcl.lisp:1.45 Tue Jan 13 17:51:07 2004 +++ slime/swank-openmcl.lisp Wed Jan 14 01:53:53 2004 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.45 2004/01/13 22:51:07 heller Exp $ +;;; $Id: swank-openmcl.lisp,v 1.46 2004/01/14 06:53:53 lgorrie Exp $ ;;; ;;; @@ -93,7 +93,7 @@ (ccl:process-run-function name fn)) (defmethod emacs-connected () - (setq ccl::*interactive-abort-process* ccl::*current-process*) + (setq ccl::*interactive-abort-process* ccl::*current-process*)) ;;; From lgorrie at common-lisp.net Wed Jan 14 06:54:11 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Wed, 14 Jan 2004 01:54:11 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv13500 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Wed Jan 14 01:54:11 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.203 slime/ChangeLog:1.204 --- slime/ChangeLog:1.203 Tue Jan 13 18:03:59 2004 +++ slime/ChangeLog Wed Jan 14 01:54:11 2004 @@ -1,3 +1,8 @@ +2004-01-14 Luke Gorrie + + * swank-openmcl.lisp (emacs-connected): Typo fix (missing + close-paren). + 2004-01-13 Helmut Eller * slime.el (slime-input-complete-p): Tolerate extra close parens. From yearscapegoat at dwp.net Wed Jan 14 12:04:39 2004 From: yearscapegoat at dwp.net (yearscapegoat at dwp.net) Date: Wed, 14 Jan 2004 07:04:39 -0500 Subject: [slime-cvs] Modern way of losing whittling we;ght natural Eurasia Message-ID: Hello broadside, At last you have an opportunity to purchase good directly from manufactures. You save your money purchasing quality products from our plant's store. Today we present you FatBlast product. What is FatBlast actually? Fatblast is an advanced fat-binding supplement that removes fat from the foods you eat! Formulated with the powerful fat-binding fiber Chitosan, the proprietary blend of all-natural compounds... Our corporation was the first one who started selling this product on the web in the year 2004. Try our FDA approved product tday outlay Read about our dscounts and special bonses: http://www.sellherbs.com/fly/index.php?pid=pharmaboss spores devoted vexing kicker, spice deletions brute compiling falsity grassers automotive apothegm chuckles shanties sloper intensify seize. From wjenkner at common-lisp.net Wed Jan 14 23:43:16 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Wed, 14 Jan 2004 18:43:16 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv12769 Modified Files: swank-clisp.lisp Log Message: (with-blocked-signals): New macro. (without-interrupts): Use it. (*use-dedicated-output-stream*, *redirect-output*): Don't set them here, use the default settings. Make :linux one of *features* if we find the "LINUX" package. Date: Wed Jan 14 18:43:16 2004 Author: wjenkner Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.9 slime/swank-clisp.lisp:1.10 --- slime/swank-clisp.lisp:1.9 Tue Jan 13 14:27:24 2004 +++ slime/swank-clisp.lisp Wed Jan 14 18:43:16 2004 @@ -24,21 +24,31 @@ (use-package "SOCKET") (use-package "GRAY")) -(setq *use-dedicated-output-stream* nil) -;(setq *redirect-output* nil) +(eval-when (:compile-toplevel :execute) + (when (find-package "LINUX") + (pushnew :linux *features*))) #+linux +(defmacro with-blocked-signals ((&rest signals) &body body) + (ext:with-gensyms ("SIGPROCMASK" ret mask) + `(multiple-value-bind (,ret ,mask) + (linux:sigprocmask-set-n-save + ,linux:SIG_BLOCK + ,(do ((sigset (linux:sigset-empty) + (linux:sigset-add sigset (the fixnum (pop signals))))) + ((null signals) sigset))) + (linux:check-res ,ret 'linux:sigprocmask-set-n-save) + (unwind-protect + (progn , at body) + (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil))))) + +#+linux (defmacro without-interrupts (&body body) - `(let ((sigact (linux:signal-action-retrieve linux:SIGINT))) - (unwind-protect - (progn - (linux:set-sigprocmask linux:SIG_BLOCK (linux:sa-mask sigact)) - , at body) - (linux:set-sigprocmask linux:SIG_UNBLOCK (linux:sa-mask sigact))))) + `(with-blocked-signals (,linux:SIGINT) , at body)) #-linux -(defmacro without-interrupts (body) - body) +(defmacro without-interrupts (&body body) + `(progn , at body)) (defun without-interrupts* (fun) (without-interrupts (funcall fun))) From wjenkner at common-lisp.net Wed Jan 14 23:44:41 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Wed, 14 Jan 2004 18:44:41 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv7200 Modified Files: ChangeLog Log Message: Date: Wed Jan 14 18:44:41 2004 Author: wjenkner Index: slime/ChangeLog diff -u slime/ChangeLog:1.204 slime/ChangeLog:1.205 --- slime/ChangeLog:1.204 Wed Jan 14 01:54:11 2004 +++ slime/ChangeLog Wed Jan 14 18:44:40 2004 @@ -1,3 +1,11 @@ +2004-01-15 Wolfgang Jenkner + + * swank-clisp.lisp (with-blocked-signals): New macro. + (without-interrupts): Use it. + (*use-dedicated-output-stream*, *redirect-output*): Don't set them + here, use the default settings. + Make :linux one of *features* if we find the "LINUX" package. + 2004-01-14 Luke Gorrie * swank-openmcl.lisp (emacs-connected): Typo fix (missing From lgorrie at common-lisp.net Thu Jan 15 11:40:50 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 15 Jan 2004 06:40:50 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14085 Modified Files: swank.lisp Log Message: New support for multiprocessing and multiple connections + commentary. (with-a-connection): Macro to execute some forms "with a connection". This is used in the debugger hook to automatically create a temporary connection if needed (i.e. if the current thread doesn't already have one). (open-aux-connection): Helper function to create an extra connection to Emacs. Date: Thu Jan 15 06:40:50 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.95 slime/swank.lisp:1.96 --- slime/swank.lisp:1.95 Tue Jan 13 17:49:34 2004 +++ slime/swank.lisp Thu Jan 15 06:40:50 2004 @@ -23,9 +23,6 @@ (import '(nil t quote) package) package)) -(defvar *dispatching-connection* nil - "Connection currently being served.") - (defconstant server-port 4005 "Default port for the Swank TCP server.") @@ -70,37 +67,83 @@ (export ',fun :swank))) -;;;; Helper macros - -(defmacro with-conversation-lock (&body body) - `(call-with-conversation-lock (lambda () , at body))) - -(defmacro with-I/O-lock (&body body) - `(call-with-I/O-lock (lambda () , at body))) - -(defmacro with-io-redirection ((&optional (connection '*dispatching-connection*)) - &body body) - "Execute BODY with I/O redirection to CONNECTION. -If *REDIRECT-IO* is true, all standard I/O streams are redirected." - `(if *redirect-io* - (call-with-redirected-io ,connection (lambda () , at body)) - (progn , at body))) - +;;;; Connections +;;; +;;; Connection structures represent the network connections between +;;; Emacs and Lisp. Each has a socket stream, a set of user I/O +;;; streams that redirect to Emacs, and optionally a second socket +;;; used solely to pipe user-output to Emacs (an optimization). +;;; +;;; Initially Emacs connects to Lisp and the "main" connection is +;;; created. The thread that accepts this connection then reads and +;;; serves requests from Emacs as they arrive. Later, new connections +;;; can be created for other threads that need to talke to Emacs, +;;; e.g. to enter the debugger. +;;; +;;; Each connection is owned by the thread that accepts it. Only the +;;; owner can use a connection to communicate with Emacs, with one +;;; exception: Any thread may send out-of-band messages to Emacs using +;;; the main connection. A message is "out of band" if it is +;;; independent of the protocol state (or more specifically, if the +;;; `slime-handle-oob' elisp function can handle it). +;;; +;;; When a new thread needs to talk to Emacs it must first create a +;;; connection of its own. This is done by binding a listen-socket and +;;; asking Emacs to connect, using an out-of-band message on the main +;;; connection to tell Emacs what port to connect to. This logic is +;;; encapsulated by the WITH-A-CONNECTION macro, which will execute +;;; its body forms with a connection available, creating a temporary +;;; one if necessary. ;;; -;;;; Connection datatype +;;; Multiple threads can write to the main connection, so these writes +;;; must by synchronized. This is coarsely achieved by using the +;;; WITH-I/O-LOCK macro to globally serialize all writes to any +;;; connection. Reads do not have to be synchronized because each +;;; connection can only be read by one thread. +;;; +;;; Non-multiprocessing systems can ignore all of this. There is only +;;; one connection and only one thread, so the invariants come for +;;; free. (defstruct (connection (:conc-name connection.) (:print-function %print-connection) - (:constructor make-connection (socket-io user-input user-output user-io))) + (:constructor make-connection (owner-id socket-io dedicated-output + user-input user-output user-io))) + ;; Thread-id of the connection's owner. + (owner-id nil) ;; Raw I/O stream of socket connection. - (socket-io nil :type stream) + (socket-io nil :type stream) + ;; Optional dedicated output socket (backending `user-output' slot). + ;; Has a slot so that it can be closed with the connection. + (dedicated-output nil :type (or stream null)) ;; Streams that can be used for user interaction, with requests - ;; redirected to Emacs. These streams must be initialized but, - ;; depending on configuration, may not be used. - (user-input nil :type (or stream null)) - (user-output nil :type (or stream null)) - (user-io nil :type (or stream null))) + ;; redirected to Emacs. + (user-input nil :type (or stream null)) + (user-output nil :type (or stream null)) + (user-io nil :type (or stream null))) + +(defvar *main-connection* nil + "The main (first established) connection to Emacs. +Any thread may send out-of-band messages to Emacs using this +connection.") + +(defvar *main-thread-id* nil + "ID of the thread that established *MAIN-CONNECTION*. +Only this thread can read from or send in-band messages to the +*MAIN-CONNECTION*.") + +;; This can't be initialized right away due to our compilation/loading +;; order: it ends up calling the NO-APPLICABLE-METHOD version from +;; swank-backend before the real one loads. +(makunbound + (defvar *write-lock* nil + "Lock held while writing to sockets.")) + +(defvar *dispatching-connection* nil + "Connection currently being served. +Dynamically bound while dispatching a request that arrives from +Emacs.") (defun %print-connection (connection stream depth) (declare (ignore depth)) @@ -112,7 +155,19 @@ (:report (lambda (condition stream) (format stream "~A" (slime-read-error.condition condition))))) - +;;;; Helper macros + +(defmacro with-I/O-lock (() &body body) + `(call-with-lock-held *write-lock* (lambda () , at body))) + +(defmacro with-io-redirection ((&optional (connection '*dispatching-connection*)) + &body body) + "Execute BODY with I/O redirection to CONNECTION. +If *REDIRECT-IO* is true, all standard I/O streams are redirected." + `(if *redirect-io* + (call-with-redirected-io ,connection (lambda () , at body)) + (progn , at body))) + ;;;; TCP Server (defvar *close-swank-socket-after-setup* nil) @@ -120,6 +175,15 @@ (defvar *swank-in-background* nil) (defun start-server (port-file) + (setq *write-lock* (make-lock :name "Swank write lock")) + (if (eq *swank-in-background* :spawn) + (spawn (lambda () + (let ((*swank-in-background* nil)) + (setup-server port-file))) + :name "Swank") + (setup-server port-file))) + +(defun setup-server (port-file) (let ((socket (create-socket 0))) (announce-server-port port-file (local-port socket)) (let ((client (accept-connection socket))) @@ -127,17 +191,17 @@ (let ((connection (create-connection client))) (ecase *swank-in-background* (:fd-handler - (emacs-connected) + (init-main-connection connection) (add-input-handler client (lambda () (handle-request connection)))) - (:spawn - (spawn (lambda () - (emacs-connected) - (loop until (handle-request connection))) - :name "Swank")) ((nil) - (emacs-connected) + (init-main-connection connection) (loop until (handle-request connection)))))))) +(defun init-main-connection (connection) + (setq *main-connection* connection) + (setq *main-thread-id* (thread-id)) + (emacs-connected)) + (defun announce-server-port (file port) (with-open-file (s file :direction :output @@ -147,28 +211,31 @@ (simple-announce-function port)) (defun create-connection (socket-io) - (let ((output-fn (make-output-function socket-io)) - (input-fn (lambda () (read-user-input-from-emacs socket-io)))) - (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) - (let ((io (make-two-way-stream in out))) - (make-connection socket-io in out io))))) + (multiple-value-bind (output-fn dedicated-output) (make-output-function socket-io) + (let ((input-fn (lambda () (read-user-input-from-emacs socket-io)))) + (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) + (let ((io (make-two-way-stream in out))) + (make-connection (thread-id) socket-io dedicated-output in out io)))))) (defun make-output-function (socket-io) + "Create function to send user output to Emacs. +This function may open a dedicated socket to send output. It +returns two values: the output function, and the dedicated +stream (or NIL if none was created)." (if *use-dedicated-output-stream* (let ((stream (open-dedicated-output-stream socket-io))) - (lambda (string) - (princ string stream) - (force-output stream))) - (lambda (string) - (send-output-to-emacs string socket-io)))) - + (values (lambda (string) + (princ string stream) + (force-output stream)) + stream)) + (values (lambda (string) (send-output-to-emacs string socket-io)) + nil))) + (defun open-dedicated-output-stream (socket-io) "Open a dedicated output connection to the Emacs on SOCKET-IO. Return an output stream suitable for writing program output. This is an optimized way for Lisp to deliver output to Emacs." - ;; We start a server process, ask Emacs to connect to it, and then - ;; return the socket's stream. (let* ((socket (create-socket 0)) (port (local-port socket))) (send-to-emacs `(:open-dedicated-output-stream ,port) socket-io) @@ -184,7 +251,7 @@ (slime-read-error (e) (when *swank-debug-p* (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e)) - (close (connection.socket-io connection)) + (close-connection connection) (return-from handle-request t))))))) nil) @@ -195,18 +262,10 @@ ;;;; IO to Emacs ;;; -;;; We have two layers of I/O: -;;; ;;; The lower layer is a socket connection. Emacs sends us forms to ;;; evaluate, and we accept these by calling READ-FROM-EMACS. These ;;; evaluations can send messages back to Emacs as a side-effect by ;;; calling SEND-TO-EMACS. -;;; -;;; The upper layer is streams for redirecting I/O through Emacs, by -;;; mapping I/O requests onto messages. - -;;; These stream variables are all dynamically-bound during request -;;; processing. (defun call-with-redirected-io (connection function) "Call FUNCTION with I/O streams redirected via CONNECTION." @@ -222,10 +281,56 @@ (*terminal-io* io)) (funcall function))) +(defun current-connection () + (cond ((and *dispatching-connection* + ;; In SBCL new threads inherit the dynamic bindings of + ;; their parent. That means the *dispatching-connection* + ;; when the thread is created (e.g. from SLIME REPL) + ;; will be visible to the new thread, even though it's + ;; not the owner and mustn't use it. Must ask Dan all + ;; about this. -luke (15/Jan/2004) + #+SBCL (equal (thread-id) (connection.owner-id *dispatching-connection*))) + *dispatching-connection*) + ((equal (thread-id) *main-thread-id*) + *main-connection*) + (t nil))) + (defun current-socket-io () - (connection.socket-io *dispatching-connection*)) + (connection.socket-io (current-connection))) -(defparameter *log-events* nil) +(defmacro with-a-connection (() &body body) + "Execute BODY with a connection. +If no connection is currently available then a new one is +temporarily created for the extent of the execution. + +Thus the BODY forms can call READ-FROM-EMACS and SEND-TO-EMACS." + `(if (current-connection) + (progn , at body) + (call-with-aux-connection (lambda () , at body)))) + +(defun call-with-aux-connection (fn) + (let* ((c (open-aux-connection)) + (*dispatching-connection* c)) + (unwind-protect (funcall fn) + (close-connection c)))) + +(defun close-connection (c) + (close (connection.socket-io c)) + (when (connection.dedicated-output c) + (close (connection.dedicated-output c)))) + +(defun open-aux-connection () + (let* ((socket (create-socket 0)) + (port (local-port socket))) + (send-to-emacs `(:open-aux-connection ,port) + (connection.socket-io *main-connection*)) + (create-connection (accept-connection socket)))) + +(defun announce-aux-server (port) + (send-to-emacs `(:open-aux-connection ,port) + (connection.socket-io *main-connection*))) + +(defvar *log-events* nil) (defun log-event (format-string &rest args) "Write a message to *terminal-io* when *log-events* is non-nil. @@ -244,15 +349,14 @@ If a protocol error occurs then a SLIME-READ-ERROR is signalled." (flet ((next-byte () (char-code (read-char stream)))) (handler-case - (with-I/O-lock - (let* ((length (logior (ash (next-byte) 16) - (ash (next-byte) 8) - (next-byte))) - (string (make-string length)) - (pos (read-sequence string stream))) - (assert (= pos length) () - "Short read: length=~D pos=~D" length pos) - (read-form string))) + (let* ((length (logior (ash (next-byte) 16) + (ash (next-byte) 8) + (next-byte))) + (string (make-string length)) + (pos (read-sequence string stream))) + (assert (= pos length) () + "Short read: length=~D pos=~D" length pos) + (read-form string)) (serious-condition (c) (error (make-condition 'slime-read-error :condition c)))))) @@ -275,7 +379,7 @@ (let* ((string (prin1-to-string-for-emacs object)) (length (1+ (length string)))) (log-event "SEND: ~A~%" string) - (with-I/O-lock + (with-I/O-lock () (without-interrupts* (lambda () (loop for position from 16 downto 0 by 8 @@ -389,8 +493,8 @@ then waits to handle further requests from Emacs. Eventually returns after Emacs causes a restart to be invoked." (declare (ignore hook)) - (unless (or *processing-rpc* (not *multiprocessing-enabled*)) - (request-async-debug condition)) +;; (unless (or *processing-rpc* (not *multiprocessing-enabled*)) +;; (request-async-debug condition)) (let ((*swank-debugger-condition* condition) (*package* *buffer-package*)) (let ((*sldb-level* (1+ *sldb-level*))) @@ -402,16 +506,15 @@ or SB-DEBUG::*INVOKE-DEBUGGER-HOOK*, to install the SLIME debugger globally. Must be run from the *slime-repl* buffer or somewhere else that the slime streams are visible so that it can capture them." - (let ((package *buffer-package*) - (connection *dispatching-connection*)) + (let ((package *buffer-package*)) (labels ((slime-debug (c &optional next) - (let ((*buffer-package* package) - (*dispatching-connection* connection)) + (let ((*buffer-package* package)) ;; check emacs is still there: don't want to end up ;; in recursive debugger loops if it's disconnected - (when (open-stream-p (connection.socket-io connection)) - (with-io-redirection () - (swank-debugger-hook c next)))))) + (when (open-stream-p (connection.socket-io *main-connection*)) + (with-a-connection () + (with-io-redirection () + (swank-debugger-hook c next))))))) #'slime-debug))) (defslimefun install-global-debugger-hook () @@ -422,16 +525,6 @@ (setq *multiprocessing-enabled* t) (startup-multiprocessing)) -(defun request-async-debug (condition) - "Tell Emacs that we need to debug a condition, and wait for acknowledgement. -Called before entering the debugger for conditions that occured -asynchronously, i.e. not during an RPC from Emacs." - (send-to-emacs `(:awaiting-goahead - ,(thread-id) - ,(thread-name (thread-id)) - ,(format nil "~A" condition))) - (wait-goahead)) - (defun sldb-loop (level) (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 *sldb-initial-frames*))) @@ -1008,9 +1101,6 @@ (if errors `(("Unresolved" . ,errors)))))))) - -;; (put 'with-i/o-lock 'common-lisp-indent-function 0) -;; (put 'with-conversation-lock 'common-lisp-indent-function 0) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From lgorrie at common-lisp.net Thu Jan 15 11:41:20 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 15 Jan 2004 06:41:20 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15617 Modified Files: swank-sbcl.lisp Log Message: Implemented multiprocessing. Not perfect. Date: Thu Jan 15 06:41:20 2004 Author: lgorrie Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.49 slime/swank-sbcl.lisp:1.50 --- slime/swank-sbcl.lisp:1.49 Tue Jan 13 17:50:09 2004 +++ slime/swank-sbcl.lisp Thu Jan 15 06:41:20 2004 @@ -105,6 +105,14 @@ (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) +(defmethod make-fn-streams (input-fn output-fn) + (let* ((output (make-instance 'slime-output-stream + :output-fn output-fn)) + (input (make-instance 'slime-input-stream + :input-fn input-fn + :output-stream output))) + (values input output))) + ;;; Utilities (defvar *swank-debugger-stack-frame*) @@ -528,6 +536,30 @@ (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) + +;;;; Multiprocessing + +#+SB-THREAD +(progn + (defmethod spawn (fn &key name) + (declare (ignore name)) + (sb-thread:make-thread fn)) + + (defmethod startup-multiprocessing () + (setq *swank-in-background* :spawn)) + + (defmethod thread-id () + (sb-thread:current-thread-id)) + + (defmethod thread-name (thread-id) + (format nil "Thread ~S" thread-id)) + + (defmethod make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defmethod call-with-lock-held (lock function) + (sb-thread:with-mutex (lock) (funcall function))) +) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) From lgorrie at common-lisp.net Thu Jan 15 11:41:59 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 15 Jan 2004 06:41:59 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16640 Modified Files: swank-cmucl.lisp Log Message: Implemented new multiprocessing interface. (create-socket): Make FDs non-blocking when multiprocessing is enabled. (startup-multiprocessing): Set *swank-in-background* to :spawn. Date: Thu Jan 15 06:41:59 2004 Author: lgorrie Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.48 slime/swank-cmucl.lisp:1.49 --- slime/swank-cmucl.lisp:1.48 Tue Jan 13 17:48:25 2004 +++ slime/swank-cmucl.lisp Thu Jan 15 06:41:59 2004 @@ -13,9 +13,13 @@ (setq *swank-in-background* :fd-handler) (defmethod create-socket (port) - (ext:create-inet-listener port :stream - :reuse-address t - :host (resolve-hostname "localhost"))) + (let ((fd (ext:create-inet-listener port :stream + :reuse-address t + :host (resolve-hostname "localhost")))) + #+MP + (when *multiprocessing-enabled* + (set-fd-non-blocking fd)) + fd)) (defmethod local-port (socket) (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) @@ -24,6 +28,7 @@ (ext:close-socket (socket-fd socket))) (defmethod accept-connection (socket) + #+MP (when *multiprocessing-enabled* (mp:process-wait-until-fd-usable socket :input)) (make-socket-io-stream (ext:accept-tcp-connection socket))) (defmethod add-input-handler (socket fn) @@ -37,6 +42,9 @@ (input (make-slime-input-stream input-fn output))) (values input output))) +(defmethod spawn (fn &key (name "Anonymous")) + (mp:make-process fn :name name)) + ;;; ;;;;; Socket helpers. @@ -56,6 +64,14 @@ "Create a new input/output fd-stream for FD." (sys:make-fd-stream fd :input t :output t :element-type 'base-char)) +(defun set-fd-non-blocking (fd) + (flet ((fcntl (fd cmd arg) + (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg) + (or flags + (error "fcntl: ~A" (unix:get-unix-error-msg errno)))))) + (let ((flags (fcntl fd unix:F-GETFL 0))) + (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))) + ;;;; Stream handling @@ -1253,14 +1269,14 @@ #+MP (progn - (defvar *I/O-lock* (mp:make-lock "SWANK I/O lock")) - (defvar *conversation-lock* (mp:make-lock "SWANK conversation lock")) - (defvar *known-processes* '() ; FIXME: leakage. -luke "List of processes that have been assigned IDs. The ID is the position in the list.") (defmethod startup-multiprocessing () + (setq *swank-in-background* :spawn) + ;; Threads magic: this never returns! But top-level becomes + ;; available again. (mp::startup-idle-and-top-level-loops)) (defmethod thread-id () @@ -1280,20 +1296,13 @@ (defmethod thread-name (thread-id) (mp:process-name (lookup-thread thread-id))) - (defmethod call-with-I/O-lock (function) - (mp:with-lock-held (*I/O-lock*) - (funcall function))) + (defmethod make-lock (&key name) + (mp:make-lock name)) - (defmethod call-with-conversation-lock (function) - (mp:with-lock-held (*conversation-lock*) + (defmethod call-with-lock-held (lock function) + (mp:with-lock-held (lock) (funcall function))) - - (defmethod wait-goahead () - (mp:disable-process (mp:current-process)) - (mp:process-yield)) - - (defmethod give-goahead (thread-id) - (mp:enable-process (lookup-thread thread-id)))) +) ;;;; Epilogue From lgorrie at common-lisp.net Thu Jan 15 11:42:12 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 15 Jan 2004 06:42:12 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17516 Modified Files: swank-backend.lisp Log Message: Changed multiprocessing interface. Date: Thu Jan 15 06:42:12 2004 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.16 slime/swank-backend.lisp:1.17 --- slime/swank-backend.lisp:1.16 Tue Jan 13 13:16:37 2004 +++ slime/swank-backend.lisp Thu Jan 15 06:42:12 2004 @@ -112,9 +112,6 @@ (defgeneric add-input-handler (socket fn) (:documentation "Call FN whenever SOCKET is readable.")) -(defgeneric spawn (fn &key name) - (:documentation "Create a new process and call FN in the new process.")) - ;;; Base condition for networking errors. (define-condition network-error (error) ()) @@ -157,8 +154,6 @@ "Compile FILENAME signalling COMPILE-CONDITIONs. If LOAD-P is true, load the file after compilation.")) -;;;;; Compiler conditions - (deftype severity () '(member :error :warning :style-warning :note)) ;; Base condition type for compiler errors, warnings and notes. @@ -180,7 +175,7 @@ (location :initarg :location :accessor location))) -;;; + ;;;; Streams (defgeneric make-fn-streams (input-fn output-fn) @@ -397,6 +392,9 @@ MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a normal function.")) +(defgeneric spawn (fn &key name) + (:documentation "Create a new thread to call FN.")) + (defgeneric thread-id () (:documentation "Return a value that uniquely identifies the current thread. @@ -418,42 +416,14 @@ Thread names are be single-line strings and are meaningful to the user. They do not have to be unique.")) -(defgeneric call-with-I/O-lock (function) +(defgeneric make-lock (&key name) (:documentation - "Call FUNCTION with the \"I/O\" lock held. -Only one thread can hold the I/O lock at a time -- others are blocked -until they acquire it. When called recursively (i.e. lock already -held), simply calls FUNCTION. - -This is a low-level lock used for mutual exclusion on individual -messages read and written to the socket connecting Emacs. + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time.")) -Systems that do not support multiprocessing simply call FUNCTION.")) - -(defgeneric call-with-conversation-lock (function) +(defgeneric call-with-lock-held (lock function) (:documentation - "Call FUNCTION with the \"conversation\" lock held. -The semantics are analogous to CALL-WITH-I/O-HOOK. - -This is a high-level lock used for mutual exclusion in conversations -with Emacs that can span multiple messages. The I/O lock must -separately be held when reading and writing individual messages.")) - -;;; Functions for attracting the Emacs user's attention. - -(defgeneric wait-goahead () - (:documentation - "Block until told to continue by `give-gohead'. - -Systems that do not support multiprocessing return immediately.")) - -(defgeneric give-goahead (thread-id) - (:documentation - "Permit THREAD-ID to continue from WAIT-GOAHEAD. -It is an error to call (GIVE-GOAHEAD ID) unless ID is blocking in -WAIT-GOAHEAD. - -Systems that do not support multiprocessing always signal an error.")) + "Call FUNCTION with LOCK held, queueing if necessary.")) ;;;;; Default implementation for non-MP systems @@ -471,16 +441,9 @@ (defmethod no-applicable-method ((m (eql #'thread-name)) &rest _) (declare (ignore _)) "The One True Thread") -(defmethod no-applicable-method ((m (eql #'call-with-I/O-lock)) - &rest args) - (funcall (first args))) -(defmethod no-applicable-method ((m (eql #'call-with-conversation-lock)) - &rest args) - (funcall (first args))) -(defmethod no-applicable-method ((m (eql #'wait-goahead)) &rest _) - (declare (ignore _)) - t) -(defmethod no-applicable-method ((m (eql #'give-goahead)) &rest _) +(defmethod no-applicable-method ((m (eql #'make-lock)) &rest _) (declare (ignore _)) - (error "SLIME multiprocessing not available")) + :null-lock) +(defmethod no-applicable-method ((m (eql #'call-with-lock-held)) &rest args) + (funcall (second args))) From lgorrie at common-lisp.net Thu Jan 15 11:42:51 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 15 Jan 2004 06:42:51 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18145 Modified Files: slime.el Log Message: (slime-aux-connect, slime-handle-oob): Support for (:open-aux-connection port) message where Lisp requests that Emacs make a connection. These are "auxiliary" connections which don't (or at least shouldn't) have their own REPL etc. Date: Thu Jan 15 06:42:51 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.175 slime/slime.el:1.176 --- slime/slime.el:1.175 Tue Jan 13 17:56:09 2004 +++ slime/slime.el Thu Jan 15 06:42:50 2004 @@ -962,7 +962,7 @@ (y-or-n-p "Close old connections first? ")))) (when kill-old-p (slime-disconnect)) (message "Connecting to Swank on port %S.." port) - (slime-init-connection (slime-net-connect "localhost" port) t) + (slime-init-connection (slime-net-connect "localhost" port)) (when-let (buffer (get-buffer "*inferior-lisp*")) (delete-windows-on buffer) (bury-buffer buffer)) @@ -970,6 +970,15 @@ (message "Connected to Swank server on port %S. %s" port (slime-random-words-of-encouragement))) +(defun slime-aux-connect (host port) + "Open an auxiliary connection to HOST:PORT. + +Auxiliary connections are temporary connections to specific +threads for the purposes of e.g. debugging." + (message "Opening auxiliary connection to %S:%S.." host port) + (slime-init-connection (slime-net-connect "localhost" port) t) + (message "Opening auxiliary connection to %S:%S.. done" host port)) + (defun slime-disconnect () "Disconnect all connections." (interactive) @@ -1135,21 +1144,10 @@ (defun slime-connection () "Return the connection to use for Lisp interaction." (or slime-dispatching-connection - (progn (slime-maybe-drop-buffer-connection) - slime-buffer-connection) + slime-buffer-connection slime-default-connection (error "No connection."))) -(defun slime-maybe-drop-buffer-connection () - "If the current buffer's connection is closed, offer to switch -to the default." - (when (and slime-buffer-connection - (not (eq (process-status slime-buffer-connection) 'open))) - (if (and slime-default-connection - (y-or-n-p "Buffer's connection closed; switch to default? ")) - (setq slime-buffer-connection nil) - (error "Buffer's connection closed.")))) - (defvar slime-state-name "[??]" "Name of the current state of `slime-default-connection'. For display in the mode-line.") @@ -1311,16 +1309,15 @@ (slime-with-connection-buffer () slime-state-stack)) -(defun slime-init-connection (proc &optional select) +(defun slime-init-connection (proc &optional auxp) "Initialize the stack machine." (let ((slime-dispatching-connection proc)) - (slime-init-connection-state proc) - (when (or select (null slime-default-connection)) - (slime-select-connection proc)) + (slime-init-connection-state proc auxp) + (unless auxp (slime-select-connection proc)) (sldb-cleanup) proc)) -(defun slime-init-connection-state (proc) +(defun slime-init-connection-state (proc auxp) ;; To make life simpler for the user: if this is the only open ;; connection then reset the connection counter. (when (equal slime-net-processes (list proc)) @@ -1328,14 +1325,15 @@ (slime-with-connection-buffer () (setq slime-state-stack (list (slime-idle-state))) (setq slime-connection-number (incf slime-connection-counter))) - (when-let (repl-buffer (slime-repl-buffer)) - ;; REPL buffer already exists - update its local - ;; `slime-connection' binding. - (with-current-buffer repl-buffer - (setq slime-buffer-connection proc))) - (setf (slime-pid) (slime-eval '(swank:getpid))) - (when slime-global-debugger-hook - (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER")) + (unless auxp + (setf (slime-pid) (slime-eval '(swank:getpid))) + (when-let (repl-buffer (slime-repl-buffer)) + ;; REPL buffer already exists - update its local + ;; `slime-connection' binding. + (with-current-buffer repl-buffer + (setq slime-buffer-connection proc))) + (when slime-global-debugger-hook + (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER"))) (setf (sldb-level) 0)) (defun slime-activate-state () @@ -1398,6 +1396,8 @@ ((:open-dedicated-output-stream port) (slime-open-stream-to-lisp port) t) + ((:open-aux-connection port) + (slime-aux-connect "localhost" port)) ((:%apply fn args) (apply (intern fn) args) t) From lgorrie at common-lisp.net Thu Jan 15 11:43:02 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Thu, 15 Jan 2004 06:43:02 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18560 Modified Files: ChangeLog Log Message: Date: Thu Jan 15 06:43:01 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.205 slime/ChangeLog:1.206 --- slime/ChangeLog:1.205 Wed Jan 14 18:44:40 2004 +++ slime/ChangeLog Thu Jan 15 06:43:01 2004 @@ -1,3 +1,28 @@ +2004-01-15 Luke Gorrie + + * slime.el (slime-aux-connect, slime-handle-oob): Support for + (:open-aux-connection port) message where Lisp requests that + Emacs make a connection. These are "auxiliary" connections which + don't (or at least shouldn't) have their own REPL etc. + + * swank.lisp: New support for multiprocessing and multiple + connections + commentary. + (with-a-connection): Macro to execute some forms "with a + connection". This is used in the debugger hook to automatically + create a temporary connection if needed (i.e. if the current + thread doesn't already have one). + (open-aux-connection): Helper function to create an extra + connection to Emacs. + + * swank-sbcl.lisp: Implemented multiprocessing. Not perfect. + + * swank-cmucl.lisp: Implemented new multiprocessing interface. + (create-socket): Make FDs non-blocking when multiprocessing is + enabled. + (startup-multiprocessing): Set *swank-in-background* to :spawn. + + * swank-backend.lisp: Changed multiprocessing interface. + 2004-01-15 Wolfgang Jenkner * swank-clisp.lisp (with-blocked-signals): New macro. From heller at common-lisp.net Thu Jan 15 18:15:00 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:15:00 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22572 Modified Files: swank-backend.lisp Log Message: (remove-input-handlers): New function. Date: Thu Jan 15 13:15:00 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.17 slime/swank-backend.lisp:1.18 --- slime/swank-backend.lisp:1.17 Thu Jan 15 06:42:12 2004 +++ slime/swank-backend.lisp Thu Jan 15 13:15:00 2004 @@ -112,6 +112,9 @@ (defgeneric add-input-handler (socket fn) (:documentation "Call FN whenever SOCKET is readable.")) +(defgeneric remove-input-handlers (socket) + (:documentation "Remove all input handlers for SOCKET.")) + ;;; Base condition for networking errors. (define-condition network-error (error) ()) From heller at common-lisp.net Thu Jan 15 18:17:09 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:17:09 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9793 Modified Files: swank.lisp Log Message: (serve-requests): New function. (setup-server): Use it. (start-server): Pass backgroud to setup-server. (create-connection): Check the protocol version. (changelog-date): New function. (make-output-function): Use write-string instead of princ. Date: Thu Jan 15 13:17:09 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.96 slime/swank.lisp:1.97 --- slime/swank.lisp:1.96 Thu Jan 15 06:40:50 2004 +++ slime/swank.lisp Thu Jan 15 13:17:09 2004 @@ -177,25 +177,29 @@ (defun start-server (port-file) (setq *write-lock* (make-lock :name "Swank write lock")) (if (eq *swank-in-background* :spawn) - (spawn (lambda () - (let ((*swank-in-background* nil)) - (setup-server port-file))) + (spawn (lambda () (setup-server port-file nil)) :name "Swank") - (setup-server port-file))) + (setup-server port-file *swank-in-background*))) -(defun setup-server (port-file) +(defun setup-server (port-file background) (let ((socket (create-socket 0))) (announce-server-port port-file (local-port socket)) (let ((client (accept-connection socket))) (close-socket socket) (let ((connection (create-connection client))) - (ecase *swank-in-background* - (:fd-handler - (init-main-connection connection) - (add-input-handler client (lambda () (handle-request connection)))) - ((nil) - (init-main-connection connection) - (loop until (handle-request connection)))))))) + (init-main-connection connection) + (serve-requests client connection background))))) + +(defun serve-requests (client connection background) + (ecase background + (:fd-handler (add-input-handler + client (lambda () + (loop (cond ((handle-request connection) + (remove-input-handlers client) + (return)) + ((listen client)) + (t (return))))))) + ((nil) (loop until (handle-request connection))))) (defun init-main-connection (connection) (setq *main-connection* connection) @@ -211,11 +215,14 @@ (simple-announce-function port)) (defun create-connection (socket-io) - (multiple-value-bind (output-fn dedicated-output) (make-output-function socket-io) + (send-to-emacs `(:check-protocol-version ,(changelog-date)) socket-io) + (multiple-value-bind (output-fn dedicated-output) + (make-output-function socket-io) (let ((input-fn (lambda () (read-user-input-from-emacs socket-io)))) (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) (let ((io (make-two-way-stream in out))) - (make-connection (thread-id) socket-io dedicated-output in out io)))))) + (make-connection (thread-id) socket-io dedicated-output + in out io)))))) (defun make-output-function (socket-io) "Create function to send user output to Emacs. @@ -225,12 +232,12 @@ (if *use-dedicated-output-stream* (let ((stream (open-dedicated-output-stream socket-io))) (values (lambda (string) - (princ string stream) + (write-string string stream) (force-output stream)) stream)) (values (lambda (string) (send-output-to-emacs string socket-io)) nil))) - + (defun open-dedicated-output-stream (socket-io) "Open a dedicated output connection to the Emacs on SOCKET-IO. Return an output stream suitable for writing program output. @@ -258,6 +265,18 @@ (defun simple-announce-function (port) (when *swank-debug-p* (format *debug-io* "~&;; Swank started at port: ~D.~%" port))) + +(defun changelog-date () + "Return the datestring of the latest ChangeLog entry. The date is +determined at compile time." + (macrolet ((date () + (let* ((dir (pathname-directory *compile-file-pathname*)) + (changelog (make-pathname :name "ChangeLog" + :directory dir)) + (date (with-open-file (file changelog :direction :input) + (string (read file))))) + `(quote ,date)))) + (date))) ;;;; IO to Emacs From heller at common-lisp.net Thu Jan 15 18:23:53 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:23:53 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16290 Modified Files: slime.el Log Message: (slime-connect): (slime-changelog-date, slime-check-protocol-version): New functions. (slime-handle-oob): Handle :check-protocol-version event. (slime-init-output-buffer): Print some info about the remote Lisp. (slime-note-transcript-start): Renamed from slime-insert-transcript-delimiter. (slime-note-transcript-end): New function. (slime-with-output-end-mark, slime-repl-insert-prompt) (slime-repl-show-result, slime-compile-file) (slime-show-evaluation-result): Insert output from eval commands after the prompt and asynchronous output before the prompt. Needs documentation. (repl-test, repl-read, interactive-eval-output): New tests. (slime-flush-output): Accept output from all processes. Date: Thu Jan 15 13:23:52 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.176 slime/slime.el:1.177 --- slime/slime.el:1.176 Thu Jan 15 06:42:50 2004 +++ slime/slime.el Thu Jan 15 13:23:51 2004 @@ -966,10 +966,35 @@ (when-let (buffer (get-buffer "*inferior-lisp*")) (delete-windows-on buffer) (bury-buffer buffer)) - (pop-to-buffer (slime-output-buffer)) + (slime-init-output-buffer) (message "Connected to Swank server on port %S. %s" port (slime-random-words-of-encouragement))) +(defun slime-changelog-date () + "Return the datestring of the latest entry in the ChangeLog file. +If the function is compiled (with the file-compiler) return the date +of the newest at compile time. If the function is interpreted read +the ChangeLog file at runtime." + (macrolet ((date () + (let* ((dir (or (and byte-compile-current-file + (file-name-directory + byte-compile-current-file)) + slime-path)) + (file (concat dir "ChangeLog")) + (date (with-temp-buffer + (insert-file-contents file nil 0 100) + (goto-char (point-min)) + (symbol-name (read (current-buffer)))))) + `(quote ,date)))) + (date))) + +(defun slime-check-protocol-version (lisp-version) + "Signal an error LISP-VERSION equal to `slime-changelog-date'" + (unless (and lisp-version (equal lisp-version (slime-changelog-date))) + (slime-disconnect) + (error "Protocol mismatch: Lisp: %s ELisp: %s" + lisp-version (slime-changelog-date)))) + (defun slime-aux-connect (host port) "Open an auxiliary connection to HOST:PORT. @@ -1335,7 +1360,7 @@ (when slime-global-debugger-hook (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER"))) (setf (sldb-level) 0)) - + (defun slime-activate-state () "Activate the current state. This delivers an (activate) event to the state function, and updates @@ -1397,7 +1422,11 @@ (slime-open-stream-to-lisp port) t) ((:open-aux-connection port) - (slime-aux-connect "localhost" port)) + (slime-aux-connect "localhost" port) + t) + ((:check-protocol-version version) + (slime-check-protocol-version version) + t) ((:%apply fn args) (apply (intern fn) args) t) @@ -1781,21 +1810,37 @@ (set-marker-insertion-type slime-repl-input-end-mark t) (set-marker-insertion-type slime-output-end t) (set-marker-insertion-type slime-repl-prompt-start-mark t) - (slime-repl-insert-prompt) (current-buffer))))) -(defun slime-insert-transcript-delimiter (string) +(defun slime-init-output-buffer () + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (slime-repl-insert-prompt + (format "; %s Port: %s Pid: %s" + (slime-eval '(cl:lisp-implementation-type)) + (process-contact (slime-connection)) + (slime-pid))) + (pop-to-buffer (current-buffer)))) + +(defun slime-note-transcript-start (string) + (with-current-buffer (slime-output-buffer) + (goto-char (point-max)) + (slime-mark-input-end) + (slime-insert-propertized + '(slime-transcript-delimiter t) + (if (bolp) "" "\n") + ";;;; " (subst-char-in-string ?\n ?\ + (substring string 0 + (min 60 (length string)))) + " ...\n") + (slime-mark-output-start))) + +(defun slime-note-transcript-end () (with-current-buffer (slime-output-buffer) - (save-excursion - (goto-char slime-repl-prompt-start-mark) - (slime-insert-propertized - '(slime-transcript-delimiter t) - (if (bolp) "" "\n") - ";;;; " (subst-char-in-string ?\n ?\ - (substring string 0 - (min 60 (length string)))) - " ...\n") - (slime-mark-output-start)))) + (goto-char (point-max)) + (slime-flush-output) + (slime-with-output-end-mark + (slime-repl-insert-prompt "")))) (defvar slime-show-last-output-function 'slime-maybe-display-output-buffer @@ -1805,7 +1850,7 @@ (defun slime-show-last-output-region (start end) (when (< start end) - (slime-display-buffer-region (current-buffer) start + (slime-display-buffer-region (current-buffer) (1- start) slime-repl-input-start-mark))) (defun slime-maybe-display-output-buffer (start end) @@ -1814,8 +1859,7 @@ (display-buffer (current-buffer)))) (defun slime-flush-output () - (when-let (stream (get-process "*lisp-output-stream*")) - (while (accept-process-output stream 0 20)))) + (while (accept-process-output nil 0 20))) (defun slime-show-last-output () "Show the output from the last Lisp evaluation." @@ -1843,18 +1887,16 @@ , at body (when-let (w (get-buffer-window (current-buffer) t)) (set-window-point w (point))) - (when (= start slime-repl-input-start-mark) + (when (= start slime-repl-input-start-mark) (set-marker slime-repl-input-start-mark (point))))) (t (save-excursion (goto-char slime-output-end) - , at body - (unless (eolp) - (insert "\n") - (set-marker slime-output-end (1- slime-output-end)))))))) + , at body))))) (defun slime-output-filter (process string) - (slime-output-string string)) + (when (slime-connected-p) + (slime-output-string string))) (defun slime-open-stream-to-lisp (port) (let ((stream (open-network-stream "*lisp-output-stream*" @@ -1879,11 +1921,6 @@ (pop-to-buffer (current-buffer) t)) (goto-char (point-max))) -(defun slime-show-output-buffer () - (slime-show-last-output) - (with-current-buffer (slime-output-buffer) - (display-buffer (slime-output-buffer) t t))) - ;;; REPL @@ -1927,22 +1964,25 @@ (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) -(defun slime-repl-insert-prompt () +(defun slime-repl-insert-prompt (result) (let ((start (point))) (unless (bolp) (insert "\n")) - (slime-propertize-region - '(face font-lock-keyword-face - read-only t - intangible t - slime-repl-prompt t - ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) - ;; xemacs stuff - start-open t end-open t) - (insert (slime-lisp-package) "> ")) - (set-marker slime-output-end start) - (set-marker slime-repl-prompt-start-mark (1+ start) (current-buffer)) - (slime-mark-input-start))) + (insert result) + (unless (bolp) (insert "\n")) + (let ((prompt-start (point))) + (slime-propertize-region + '(face font-lock-keyword-face + read-only t + intangible t + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) + (insert (slime-lisp-package) "> ")) + (set-marker slime-output-end start) + (set-marker slime-repl-prompt-start-mark prompt-start (current-buffer)) + (slime-mark-input-start)))) (defun slime-repl-current-input () "Return the current input as string. The input is the region from @@ -1977,11 +2017,9 @@ (defun slime-repl-show-result (result) (with-current-buffer (slime-output-buffer) + (slime-flush-output) (goto-char (point-max)) - (let ((start (point))) - (insert result "\n") - (slime-repl-insert-prompt) - (set-marker slime-output-end start)))) + (slime-repl-insert-prompt result))) (defun slime-repl-show-abort () (with-current-buffer (slime-output-buffer) @@ -1991,8 +2029,9 @@ (slime-rex () ((list 'swank:listener-eval "") nil) ((:ok result) (with-current-buffer (slime-output-buffer) + (slime-flush-output) (slime-with-output-end-mark - (slime-repl-insert-prompt)) + (slime-repl-insert-prompt "")) (goto-char (point-max))))))) (defun slime-mark-input-start () @@ -2327,7 +2366,7 @@ (unless (eq major-mode 'lisp-mode) (error "Only valid in lisp-mode")) (save-some-buffers) - (slime-insert-transcript-delimiter + (slime-note-transcript-start (format "Compile file %s" (buffer-file-name))) (slime-display-output-buffer) (slime-eval-async @@ -2442,6 +2481,7 @@ (defun slime-compilation-finished-continuation () (lexical-let ((buffer (current-buffer))) (lambda (result) + (slime-note-transcript-end) (slime-compilation-finished result buffer)))) (defun slime-highlight-notes (notes) @@ -3234,7 +3274,7 @@ (defun slime-interactive-eval (string) "Read and evaluate STRING and print value in minibuffer. " (interactive (list (slime-read-from-minibuffer "Slime Eval: "))) - (slime-insert-transcript-delimiter string) + (slime-note-transcript-start string) (slime-eval-async `(swank:interactive-eval ,string) (slime-buffer-package t) @@ -3260,6 +3300,8 @@ window)))))) (defun slime-show-evaluation-result (value) + (with-current-buffer (slime-output-buffer) + (slime-note-transcript-end)) (slime-show-last-output) (message "=> %s" value)) @@ -5045,7 +5087,104 @@ (equal (format "\"%s\"" package-name) p)) (slime-check ("slime-lisp-package is in %S." nicknames) (member (slime-lisp-package) nicknames))))) - + +(def-slime-test repl-test + (input result-contents) + "Test simple commands in the minibuffer." + '(("(+ 1 2)" "(+ 1 2) +3 +SWANK> ") + ("(princ 10)" "(princ 10) +10 +10 +SWANK> " + ) + ("(princ 10)(princ 20)" "(princ 10)(princ 20) +1020 +20 +SWANK> " + ) + ("(dotimes (i 10 77) (princ i) (terpri))" + "(dotimes (i 10 77) (princ i) (terpri)) +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +77 +SWANK> " + ) + ) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (insert input) + (slime-check ("Buffer contains input: %S" input) + (equal input (buffer-string))) + (call-interactively 'slime-repl-return) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check ("Buffer contains result: %S" result-contents) + (equal result-contents (buffer-string))))) + +(def-slime-test repl-read + (prompt input result-contents) + "Test simple commands in the minibuffer." + '(("(read-line)" "foo" "(values (read-line)) +foo +\"foo\" +SWANK> ") + ("(read-char)" "1" "(values (read-char)) +1 +#\\1 +SWANK> ") + ("(read)" "(+ 2 3 +4)" "(values (read)) +(+ 2 3 +4) +(+ 2 3 4) +SWANK> ") + ) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (insert (format "(values %s)" prompt)) + (call-interactively 'slime-repl-return) + (slime-sync-state-stack '(slime-read-string-state + slime-evaluating-state + slime-idle-state) + 5) + (insert input) + (call-interactively 'slime-repl-return) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check ("Buffer contains result: %S" result-contents) + (equal result-contents (buffer-string))))) + +(def-slime-test interactive-eval-output + (input result-contents visiblep) + "Test simple commands in the minibuffer." + '(("(+ 1 2)" ";;;; (+ 1 2) ... +SWANK> " nil) + ("(princ 10)" ";;;; (princ 10) ... +10 +SWANK> " t)) + (with-current-buffer (slime-output-buffer) + (setf (slime-lisp-package) "SWANK")) + (kill-buffer (slime-output-buffer)) + (with-current-buffer (slime-output-buffer) + (slime-interactive-eval input) + (slime-sync-state-stack '(slime-idle-state) 5) + (slime-check ("Buffer contains result: %S" result-contents) + (equal result-contents (buffer-string))) + (slime-check ("Buffer visible?") + (eq visiblep (not (not (get-buffer-window (current-buffer)))))))) + ;;; Portability library From heller at common-lisp.net Thu Jan 15 18:27:41 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:27:41 -0500 Subject: [slime-cvs] CVS update: slime/swank-loader.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21760 Modified Files: swank-loader.lisp Log Message: (compile-files-if-needed-serially): Don't handle compilation errors. We must compile everything because changelog-date requires *compile-file-truename*. Date: Thu Jan 15 13:27:40 2004 Author: heller Index: slime/swank-loader.lisp diff -u slime/swank-loader.lisp:1.12 slime/swank-loader.lisp:1.13 --- slime/swank-loader.lisp:1.12 Tue Jan 6 08:10:29 2004 +++ slime/swank-loader.lisp Thu Jan 15 13:27:40 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-loader.lisp,v 1.12 2004/01/06 13:10:29 heller Exp $ +;;; $Id: swank-loader.lisp,v 1.13 2004/01/15 18:27:40 heller Exp $ ;;; (cl:defpackage :swank-loader @@ -58,10 +58,12 @@ (compile-file source-pathname) (setq needs-recompile t)) (load binary-pathname)) + #+(or) (error () ;; If an error occurs compiling, load the source instead ;; so we can try to debug it. - (load source-pathname)))))))) + (load source-pathname)) + )))))) (defun user-init-file () "Return the name of the user init file or nil." @@ -71,8 +73,8 @@ #+mswindows (make-pathname :name "_swank" :type "lsp")))) (compile-files-if-needed-serially - (list* (make-swank-pathname "swank-backend") *swank-pathname* - *sysdep-pathnames*)) + (list* (make-swank-pathname "swank-backend") *swank-pathname* + *sysdep-pathnames*)) (when (user-init-file) (load (user-init-file))) From heller at common-lisp.net Thu Jan 15 18:29:22 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:29:22 -0500 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8736 Modified Files: swank-allegro.lisp Log Message: (excl:stream-read-char-no-hang): Import it. (emacs-connected): Add default method. The method for no-applicable-method doesn't seem to work. ACL bug? Date: Thu Jan 15 13:29:22 2004 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.6 slime/swank-allegro.lisp:1.7 --- slime/swank-allegro.lisp:1.6 Tue Jan 13 13:20:04 2004 +++ slime/swank-allegro.lisp Thu Jan 15 13:29:22 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.6 2004/01/13 18:20:04 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.7 2004/01/15 18:29:22 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -29,6 +29,7 @@ excl:stream-unread-char excl:stream-clear-input excl:stream-line-column + excl:stream-read-char-no-hang )) (defun without-interrupts* (body) @@ -50,6 +51,8 @@ (defmethod spawn (fn &key name) (mp:process-run-function name fn)) + +(defmethod emacs-connected ()) ;;; From heller at common-lisp.net Thu Jan 15 18:30:32 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:30:32 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19520 Modified Files: swank-cmucl.lisp Log Message: (remove-input-handlers): New method. Date: Thu Jan 15 13:30:32 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.49 slime/swank-cmucl.lisp:1.50 --- slime/swank-cmucl.lisp:1.49 Thu Jan 15 06:41:59 2004 +++ slime/swank-cmucl.lisp Thu Jan 15 13:30:30 2004 @@ -37,6 +37,10 @@ (funcall fn))) (system:add-fd-handler (socket-fd socket) :input #'callback))) +(defmethod remove-input-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket)) + (close socket)) + (defmethod make-fn-streams (input-fn output-fn) (let* ((output (make-slime-output-stream output-fn)) (input (make-slime-input-stream input-fn output))) From heller at common-lisp.net Thu Jan 15 18:31:05 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:31:05 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21760 Modified Files: swank-sbcl.lisp Log Message: (remove-input-handlers): New method. Date: Thu Jan 15 13:31:04 2004 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.50 slime/swank-sbcl.lisp:1.51 --- slime/swank-sbcl.lisp:1.50 Thu Jan 15 06:41:20 2004 +++ slime/swank-sbcl.lisp Thu Jan 15 13:31:04 2004 @@ -87,6 +87,10 @@ (declare (ignore fd)) (funcall fn)))) +(defmethod remove-input-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (close socket)) + (defun socket-fd (socket) (etypecase socket (fixnum socket) From heller at common-lisp.net Thu Jan 15 18:34:48 2004 From: heller at common-lisp.net (Helmut Eller) Date: Thu, 15 Jan 2004 13:34:48 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14822 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Thu Jan 15 13:34:47 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.206 slime/ChangeLog:1.207 --- slime/ChangeLog:1.206 Thu Jan 15 06:43:01 2004 +++ slime/ChangeLog Thu Jan 15 13:34:46 2004 @@ -1,3 +1,41 @@ +2004-01-15 Helmut Eller + + * swank-sbcl.lisp, swank-cmucl.lisp (remove-input-handlers): New + method. + + * swank-allegro.lisp (excl:stream-read-char-no-hang): Import it. + (emacs-connected): Add default method. The method for + no-applicable-method doesn't seem to work. ACL bug? + + * swank-loader.lisp (compile-files-if-needed-serially): Don't + handle compilation errors. We must compile everything because + changelog-date requires *compile-file-truename*. + + * slime.el: (slime-changelog-date) + (slime-check-protocol-version): New functions. + (slime-handle-oob): Handle :check-protocol-version event. + (slime-init-output-buffer): Print some info about the remote Lisp. + (slime-connect): Use it. + (slime-note-transcript-start): Renamed from + slime-insert-transcript-delimiter. + (slime-note-transcript-end): New function. + (slime-with-output-end-mark, slime-repl-insert-prompt) + (slime-repl-show-result, slime-compile-file) + (slime-show-evaluation-result): Insert output from eval commands + after the prompt and asynchronous output before the prompt. Needs + documentation. + (repl-test, repl-read, interactive-eval-output): New tests. + (slime-flush-output): Accept output from all processes. + + * swank.lisp (serve-requests): New function. + (setup-server): Use it. + (start-server): Pass backgroud to setup-server. + (create-connection): Check the protocol version. + (changelog-date): New function. + (make-output-function): Use write-string instead of princ. + + * swank-backend.lisp (remove-input-handlers): New function. + 2004-01-15 Luke Gorrie * slime.el (slime-aux-connect, slime-handle-oob): Support for From lgorrie at common-lisp.net Fri Jan 16 06:01:39 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 16 Jan 2004 01:01:39 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9729 Modified Files: slime.el Log Message: (slime-init-output-buffer): XEmacs portability fix, and use header-line-format to show info about Lisp in Emacs21. Date: Fri Jan 16 01:01:38 2004 Author: lgorrie Index: slime/slime.el diff -u slime/slime.el:1.177 slime/slime.el:1.178 --- slime/slime.el:1.177 Thu Jan 15 13:23:51 2004 +++ slime/slime.el Fri Jan 16 01:01:38 2004 @@ -1815,11 +1815,17 @@ (defun slime-init-output-buffer () (with-current-buffer (slime-output-buffer) (goto-char (point-max)) - (slime-repl-insert-prompt - (format "; %s Port: %s Pid: %s" - (slime-eval '(cl:lisp-implementation-type)) - (process-contact (slime-connection)) - (slime-pid))) + (let ((banner (format "%s Port: %s Pid: %s" + (slime-eval '(cl:lisp-implementation-type)) + (if (featurep 'xemacs) + (process-id (slime-connection)) + (process-contact (slime-connection))) + (slime-pid)))) + ;; Emacs21 has the fancy persistent header-line. + (if (boundp 'header-line-format) + (progn (setq header-line-format banner) + (slime-repl-insert-prompt "")) + (slime-repl-insert-prompt (concat "; " banner)))) (pop-to-buffer (current-buffer)))) (defun slime-note-transcript-start (string) From lgorrie at common-lisp.net Fri Jan 16 06:01:52 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 16 Jan 2004 01:01:52 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10040 Modified Files: ChangeLog Log Message: Date: Fri Jan 16 01:01:52 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.207 slime/ChangeLog:1.208 --- slime/ChangeLog:1.207 Thu Jan 15 13:34:46 2004 +++ slime/ChangeLog Fri Jan 16 01:01:51 2004 @@ -1,3 +1,8 @@ +2004-01-16 Luke Gorrie + + * slime.el (slime-init-output-buffer): XEmacs portability fix, and + use header-line-format to show info about Lisp in Emacs21. + 2004-01-15 Helmut Eller * swank-sbcl.lisp, swank-cmucl.lisp (remove-input-handlers): New From lgorrie at common-lisp.net Fri Jan 16 06:24:08 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 16 Jan 2004 01:24:08 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22181 Modified Files: swank.lisp Log Message: (changelog-date): make-pathname portability fix (from alanr). Date: Fri Jan 16 01:24:08 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.97 slime/swank.lisp:1.98 --- slime/swank.lisp:1.97 Thu Jan 15 13:17:09 2004 +++ slime/swank.lisp Fri Jan 16 01:24:08 2004 @@ -270,9 +270,10 @@ "Return the datestring of the latest ChangeLog entry. The date is determined at compile time." (macrolet ((date () - (let* ((dir (pathname-directory *compile-file-pathname*)) - (changelog (make-pathname :name "ChangeLog" - :directory dir)) + (let* ((dir (pathname-directory *compile-file-pathname*)) + (changelog (make-pathname :name "ChangeLog" :directory dir + :host (pathname-host + *compile-file-pathname*))) (date (with-open-file (file changelog :direction :input) (string (read file))))) `(quote ,date)))) From lgorrie at common-lisp.net Fri Jan 16 06:50:52 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 16 Jan 2004 01:50:52 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20417 Modified Files: swank.lisp Log Message: (changelog-date): make-pathname portability fix (from alanr). (with-io-redirection): Use (current-connection) instead of *dispatching-connection* (from alanr). Date: Fri Jan 16 01:50:52 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.98 slime/swank.lisp:1.99 --- slime/swank.lisp:1.98 Fri Jan 16 01:24:08 2004 +++ slime/swank.lisp Fri Jan 16 01:50:52 2004 @@ -160,7 +160,7 @@ (defmacro with-I/O-lock (() &body body) `(call-with-lock-held *write-lock* (lambda () , at body))) -(defmacro with-io-redirection ((&optional (connection '*dispatching-connection*)) +(defmacro with-io-redirection ((&optional (connection '(current-connection))) &body body) "Execute BODY with I/O redirection to CONNECTION. If *REDIRECT-IO* is true, all standard I/O streams are redirected." From lgorrie at common-lisp.net Fri Jan 16 06:51:08 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 16 Jan 2004 01:51:08 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21024 Modified Files: swank-openmcl.lisp Log Message: Multiprocessing support. Date: Fri Jan 16 01:51:08 2004 Author: lgorrie Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.46 slime/swank-openmcl.lisp:1.47 --- slime/swank-openmcl.lisp:1.46 Wed Jan 14 01:53:53 2004 +++ slime/swank-openmcl.lisp Fri Jan 16 01:51:08 2004 @@ -13,7 +13,7 @@ ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;;; -;;; $Id: swank-openmcl.lisp,v 1.46 2004/01/14 06:53:53 lgorrie Exp $ +;;; $Id: swank-openmcl.lisp,v 1.47 2004/01/16 06:51:08 lgorrie Exp $ ;;; ;;; @@ -667,4 +667,31 @@ (t (push (cons (string 'rest) in-list) reversed-elements) (done "The object is an improper list of length ~S.~%"))))))) + +;;; Multiprocessing + +(defvar *known-processes* '() ; FIXME: leakage. -luke + "Alist (ID . PROCESS) list of processes that we have handed out IDs for.") + +(defmethod spawn (fn &key name) + (ccl:process-run-function (or name "Anonymous (Swank)") fn)) + +(defmethod startup-multiprocessing () + (setq *swank-in-background* :spawn)) + +(defmethod thread-id () + (let ((id (ccl::process-serial-number ccl:*current-process*))) + ;; Possibly not thread-safe. + (pushnew (cons id ccl:*current-process*) *known-processes*) + id)) + +(defmethod thread-name (thread-id) + (ccl::process-name (cdr (assq thread-id *known-processes*)))) + +(defmethod make-lock (&key name) + (ccl:make-lock name)) + +(defmethod call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) From lgorrie at common-lisp.net Fri Jan 16 06:51:15 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 16 Jan 2004 01:51:15 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21519 Modified Files: ChangeLog Log Message: Date: Fri Jan 16 01:51:15 2004 Author: lgorrie Index: slime/ChangeLog diff -u slime/ChangeLog:1.208 slime/ChangeLog:1.209 --- slime/ChangeLog:1.208 Fri Jan 16 01:01:51 2004 +++ slime/ChangeLog Fri Jan 16 01:51:15 2004 @@ -1,5 +1,12 @@ 2004-01-16 Luke Gorrie + * swank-openmcl.lisp: Multiprocessing support. + + * swank.lisp (changelog-date): make-pathname portability fix + (from alanr). + (with-io-redirection): Use (current-connection) instead of + *dispatching-connection* (from alanr). + * slime.el (slime-init-output-buffer): XEmacs portability fix, and use header-line-format to show info about Lisp in Emacs21. From lgorrie at common-lisp.net Fri Jan 16 07:10:30 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Fri, 16 Jan 2004 02:10:30 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20996 Modified Files: swank-openmcl.lisp Log Message: Removed $Id$ tag that was making diffs noisy. Date: Fri Jan 16 02:10:29 2004 Author: lgorrie Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.47 slime/swank-openmcl.lisp:1.48 --- slime/swank-openmcl.lisp:1.47 Fri Jan 16 01:51:08 2004 +++ slime/swank-openmcl.lisp Fri Jan 16 02:10:29 2004 @@ -12,9 +12,6 @@ ;;; ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html -;;; -;;; $Id: swank-openmcl.lisp,v 1.47 2004/01/16 06:51:08 lgorrie Exp $ -;;; ;;; ;;; This is the beginning of a Slime backend for OpenMCL. It has been From heller at common-lisp.net Fri Jan 16 07:23:59 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 02:23:59 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19890 Modified Files: slime.el Log Message: Numerous REPL related fixes. Date: Fri Jan 16 02:23:59 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.178 slime/slime.el:1.179 --- slime/slime.el:1.178 Fri Jan 16 01:01:38 2004 +++ slime/slime.el Fri Jan 16 02:23:59 2004 @@ -1792,7 +1792,7 @@ (defvar slime-output-end nil "Marker for end of output. New output is inserted at this mark.")) -(defun slime-output-buffer () +(defun slime-output-buffer (&optional noprompt) "Return the output buffer, create it if necessary." (or (slime-repl-buffer) (let ((connection (slime-connection))) @@ -1810,11 +1810,11 @@ (set-marker-insertion-type slime-repl-input-end-mark t) (set-marker-insertion-type slime-output-end t) (set-marker-insertion-type slime-repl-prompt-start-mark t) + (unless noprompt (slime-repl-insert-prompt "" 0)) (current-buffer))))) (defun slime-init-output-buffer () - (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) + (with-current-buffer (slime-output-buffer t) (let ((banner (format "%s Port: %s Pid: %s" (slime-eval '(cl:lisp-implementation-type)) (if (featurep 'xemacs) @@ -1828,26 +1828,6 @@ (slime-repl-insert-prompt (concat "; " banner)))) (pop-to-buffer (current-buffer)))) -(defun slime-note-transcript-start (string) - (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (slime-mark-input-end) - (slime-insert-propertized - '(slime-transcript-delimiter t) - (if (bolp) "" "\n") - ";;;; " (subst-char-in-string ?\n ?\ - (substring string 0 - (min 60 (length string)))) - " ...\n") - (slime-mark-output-start))) - -(defun slime-note-transcript-end () - (with-current-buffer (slime-output-buffer) - (goto-char (point-max)) - (slime-flush-output) - (slime-with-output-end-mark - (slime-repl-insert-prompt "")))) - (defvar slime-show-last-output-function 'slime-maybe-display-output-buffer "*This function is called when a evaluation request is finished. @@ -1901,7 +1881,8 @@ , at body))))) (defun slime-output-filter (process string) - (when (slime-connected-p) + (when (and (slime-connected-p) + (plusp (length string))) (slime-output-string string))) (defun slime-open-stream-to-lisp (port) @@ -1917,7 +1898,11 @@ (slime-with-output-end-mark (slime-insert-propertized (list 'face 'slime-repl-output-face) - string)))) + string) + (when (and (= (point) slime-repl-prompt-start-mark) + (not (bolp))) + (insert "\n") + (set-marker slime-output-end (1- (point))))))) (defun slime-switch-to-output-buffer () "Select the output buffer, preferably in a different window." @@ -1970,7 +1955,9 @@ (slime-setup-command-hooks) (run-hooks 'slime-repl-mode-hook)) -(defun slime-repl-insert-prompt (result) +(defun slime-repl-insert-prompt (result &optional time) + (slime-flush-output) + (goto-char (point-max)) (let ((start (point))) (unless (bolp) (insert "\n")) (insert result) @@ -1987,8 +1974,21 @@ start-open t end-open t) (insert (slime-lisp-package) "> ")) (set-marker slime-output-end start) - (set-marker slime-repl-prompt-start-mark prompt-start (current-buffer)) - (slime-mark-input-start)))) + (set-marker slime-repl-prompt-start-mark prompt-start) + (slime-mark-input-start) + (let ((time (or time 0.2))) + (cond ((zerop time) + (slime-repl-move-output-mark-before-prompt (current-buffer))) + (t + (run-at-time time nil 'slime-repl-move-output-mark-before-prompt + (current-buffer)))))))) + +(defun slime-repl-move-output-mark-before-prompt (buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (goto-char slime-repl-prompt-start-mark) + (slime-mark-output-start))))) (defun slime-repl-current-input () "Return the current input as string. The input is the region from @@ -2012,7 +2012,8 @@ (defun slime-repl-eval-string (string) (slime-rex () ((list 'swank:listener-eval string) (slime-lisp-package)) - ((:ok result) (slime-repl-show-result result)) + ((:ok result) (with-current-buffer (slime-output-buffer) + (slime-repl-insert-prompt result))) ((:abort) (slime-repl-show-abort)))) (defun slime-repl-send-string (string) @@ -2021,12 +2022,6 @@ (slime-idle-state (slime-repl-eval-string string)) (slime-read-string-state (slime-repl-return-string string)))) -(defun slime-repl-show-result (result) - (with-current-buffer (slime-output-buffer) - (slime-flush-output) - (goto-char (point-max)) - (slime-repl-insert-prompt result))) - (defun slime-repl-show-abort () (with-current-buffer (slime-output-buffer) (slime-with-output-end-mark @@ -2035,10 +2030,7 @@ (slime-rex () ((list 'swank:listener-eval "") nil) ((:ok result) (with-current-buffer (slime-output-buffer) - (slime-flush-output) - (slime-with-output-end-mark - (slime-repl-insert-prompt "")) - (goto-char (point-max))))))) + (slime-repl-insert-prompt "")))))) (defun slime-mark-input-start () (set-marker slime-repl-last-input-start-mark @@ -2046,9 +2038,6 @@ (set-marker slime-repl-input-start-mark (point) (current-buffer)) (set-marker slime-repl-input-end-mark (point) (current-buffer))) -(defun slime-mark-input-end () - (set-marker slime-repl-input-end-mark (point-min))) - (defun slime-mark-output-start () (set-marker slime-output-start (point)) (set-marker slime-output-end (point))) @@ -2156,8 +2145,8 @@ (goto-char slime-repl-input-end-mark) (add-text-properties slime-repl-input-start-mark (point) '(face slime-repl-input-face rear-nonsticky (face))) - (slime-mark-input-end) (slime-mark-output-start) + (slime-mark-input-start) (slime-repl-send-string input))) (defun slime-repl-closing-return () @@ -2334,8 +2323,8 @@ (defun slime-repl-read-string () (slime-switch-to-output-buffer) + (goto-char slime-repl-input-start-mark) (slime-mark-output-end) - (slime-mark-input-start) (slime-repl-read-mode 1)) (defun slime-repl-return-string (string) @@ -2372,7 +2361,7 @@ (unless (eq major-mode 'lisp-mode) (error "Only valid in lisp-mode")) (save-some-buffers) - (slime-note-transcript-start + (slime-insert-transcript-delimiter (format "Compile file %s" (buffer-file-name))) (slime-display-output-buffer) (slime-eval-async @@ -2487,7 +2476,6 @@ (defun slime-compilation-finished-continuation () (lexical-let ((buffer (current-buffer))) (lambda (result) - (slime-note-transcript-end) (slime-compilation-finished result buffer)))) (defun slime-highlight-notes (notes) @@ -3277,16 +3265,41 @@ ;;; Interactive evaluation. +(defun slime-eval-with-transcript (form package &optional fn) + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (slime-mark-output-start)) + (with-lexical-bindings (fn) + (slime-eval-async form package + (lambda (value) + (with-current-buffer (slime-output-buffer) + (cond (fn (funcall fn value)) + (t (message "=> %s" value))) + (slime-show-last-output))))))) + +(defun slime-eval-describe (form) + (lexical-let ((package (slime-buffer-package))) + (slime-eval-with-transcript + form package + (lambda (string) (slime-show-description string package))))) + +(defun slime-insert-transcript-delimiter (string) + (with-current-buffer (slime-output-buffer) + (slime-with-output-end-mark + (unless (bolp) (insert "\n")) + (slime-insert-propertized + '(slime-transcript-delimiter t) + ";;;; " (subst-char-in-string ?\n ?\ + (substring string 0 + (min 60 (length string)))) + " ...\n")))) + (defun slime-interactive-eval (string) "Read and evaluate STRING and print value in minibuffer. " (interactive (list (slime-read-from-minibuffer "Slime Eval: "))) - (slime-note-transcript-start string) - (slime-eval-async - `(swank:interactive-eval ,string) - (slime-buffer-package t) - (if current-prefix-arg - (slime-insert-evaluation-result-continuation) - (slime-show-evaluation-result-continuation)))) + (slime-insert-transcript-delimiter string) + (slime-eval-with-transcript `(swank:interactive-eval ,string) + (slime-buffer-package t))) (defun slime-display-buffer-region (buffer start end &optional other-window) "Like `display-buffer', but only display the specified region." @@ -3304,24 +3317,6 @@ (set-window-text-height window (/ (1- (frame-height)) 2))) (shrink-window-if-larger-than-buffer window) window)))))) - -(defun slime-show-evaluation-result (value) - (with-current-buffer (slime-output-buffer) - (slime-note-transcript-end)) - (slime-show-last-output) - (message "=> %s" value)) - -(defun slime-show-evaluation-result-continuation () - (lexical-let ((buffer (current-buffer))) - (lambda (value) - (with-current-buffer buffer - (slime-show-evaluation-result value))))) - -(defun slime-insert-evaluation-result-continuation () - (lexical-let ((buffer (current-buffer))) - (lambda (value) - (with-current-buffer buffer - (insert value))))) (defun slime-last-expression () (buffer-substring-no-properties (save-excursion (backward-sexp) (point)) @@ -3351,10 +3346,9 @@ (defun slime-eval-region (start end) "Evalute region." (interactive "r") - (slime-eval-async + (slime-eval-with-transcript `(swank:interactive-eval-region ,(buffer-substring-no-properties start end)) - (slime-buffer-package) - (slime-show-evaluation-result-continuation))) + (slime-buffer-package))) (defun slime-eval-buffer () "Evalute the current buffer. @@ -3367,9 +3361,8 @@ First make the variable unbound, then evaluate the entire form." (interactive (list (slime-last-expression))) - (slime-eval-async `(swank:re-evaluate-defvar ,form) - (slime-buffer-package) - (slime-show-evaluation-result-continuation))) + (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form) + (slime-buffer-package))) (defun slime-pprint-eval-last-expression () "Evalute the form before point; pprint the value in a buffer." @@ -3379,17 +3372,14 @@ (defun slime-eval-print-last-expression (string) "Evalute sexp before point; print value into the current buffer" (interactive (list (slime-last-expression))) - (slime-insert-transcript-delimiter string) - (insert "\n") - (slime-eval-async - `(swank:interactive-eval ,string) - (slime-buffer-package t) - (lexical-let ((buffer (current-buffer))) - (lambda (result) - (with-current-buffer buffer - (slime-show-last-output) - (princ result buffer) - (insert "\n")))))) + (lexical-let ((buffer (current-buffer))) + (slime-eval-with-transcript + `(swank:interactive-eval ,string) + (slime-buffer-package t) + (lambda (result) (with-current-buffer buffer + (slime-show-last-output) + (princ result buffer) + (insert "\n")))))) (defun slime-eval/compile-defun-dwim (&optional arg) "Call the computation command you want (Do What I Mean). @@ -3437,9 +3427,8 @@ nil (file-name-sans-extension (file-name-nondirectory (buffer-file-name)))))) - (slime-eval-async - `(swank:load-file ,(expand-file-name filename)) nil - (slime-show-evaluation-result-continuation))) + (slime-eval-with-transcript `(swank:load-file ,(expand-file-name filename)) + nil)) ;;; Documentation @@ -3462,13 +3451,6 @@ (slime-with-output-to-temp-buffer "*SLIME Description*" (princ string))) -(defun slime-eval-describe (form) - (let ((package (slime-buffer-package))) - (slime-eval-async - form package - (lexical-let ((package package)) - (lambda (string) (slime-show-description string package)))))) - (defun slime-describe-symbol (symbol-name) (interactive (list (slime-read-symbol-name "Describe symbol: "))) (when (not symbol-name) @@ -4857,6 +4839,10 @@ (slime-check ((or test-name "Automaton in idle state.")) (slime-test-state-stack '(slime-idle-state)))) +(defun slime-test-expect (name expected actual) + (slime-check ("%s:\nexpected: [%S]\n actual: [%S]" name expected actual) + (equal expected actual))) + (def-slime-test find-definition (name buffer-package) "Find the definition of a function or macro in swank.lisp." @@ -5097,21 +5083,21 @@ (def-slime-test repl-test (input result-contents) "Test simple commands in the minibuffer." - '(("(+ 1 2)" "(+ 1 2) + '(("(+ 1 2)" "SWANK> (+ 1 2) 3 SWANK> ") - ("(princ 10)" "(princ 10) + ("(princ 10)" "SWANK> (princ 10) 10 10 SWANK> " ) - ("(princ 10)(princ 20)" "(princ 10)(princ 20) + ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20) 1020 20 SWANK> " ) ("(dotimes (i 10 77) (princ i) (terpri))" - "(dotimes (i 10 77) (princ i) (terpri)) + "SWANK> (dotimes (i 10 77) (princ i) (terpri)) 0 1 2 @@ -5131,26 +5117,27 @@ (kill-buffer (slime-output-buffer)) (with-current-buffer (slime-output-buffer) (insert input) - (slime-check ("Buffer contains input: %S" input) - (equal input (buffer-string))) + (slime-test-expect "Buffer contains input" + (concat "SWANK> " input) + (buffer-string)) (call-interactively 'slime-repl-return) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check ("Buffer contains result: %S" result-contents) - (equal result-contents (buffer-string))))) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)))) (def-slime-test repl-read (prompt input result-contents) "Test simple commands in the minibuffer." - '(("(read-line)" "foo" "(values (read-line)) + '(("(read-line)" "foo" "SWANK> (values (read-line)) foo \"foo\" SWANK> ") - ("(read-char)" "1" "(values (read-char)) + ("(read-char)" "1" "SWANK> (values (read-char)) 1 #\\1 SWANK> ") ("(read)" "(+ 2 3 -4)" "(values (read)) +4)" "SWANK> (values (read)) (+ 2 3 4) (+ 2 3 4) @@ -5169,8 +5156,7 @@ (insert input) (call-interactively 'slime-repl-return) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check ("Buffer contains result: %S" result-contents) - (equal result-contents (buffer-string))))) + (slime-check"Buffer contains result" result-contents (buffer-string)))) (def-slime-test interactive-eval-output (input result-contents visiblep) @@ -5186,10 +5172,11 @@ (with-current-buffer (slime-output-buffer) (slime-interactive-eval input) (slime-sync-state-stack '(slime-idle-state) 5) - (slime-check ("Buffer contains result: %S" result-contents) - (equal result-contents (buffer-string))) - (slime-check ("Buffer visible?") - (eq visiblep (not (not (get-buffer-window (current-buffer)))))))) + (slime-test-expect "Buffer contains result" + result-contents (buffer-string)) + (slime-test-expect "Buffer visible?" + visiblep + (not (not (get-buffer-window (current-buffer))))))) ;;; Portability library From heller at common-lisp.net Fri Jan 16 07:26:13 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 02:26:13 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9374 Modified Files: swank.lisp Log Message: (changelog-date): Use *compile-file-truename* instead of *compile-file-pathname*. (with-I/O-lock, with-a-connection): The usual CLISP fixes. Date: Fri Jan 16 02:26:13 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.99 slime/swank.lisp:1.100 --- slime/swank.lisp:1.99 Fri Jan 16 01:50:52 2004 +++ slime/swank.lisp Fri Jan 16 02:26:13 2004 @@ -157,7 +157,8 @@ ;;;; Helper macros -(defmacro with-I/O-lock (() &body body) +(defmacro with-I/O-lock ((&rest ignore) &body body) + (declare (ignore ignore)) `(call-with-lock-held *write-lock* (lambda () , at body))) (defmacro with-io-redirection ((&optional (connection '(current-connection))) @@ -270,10 +271,11 @@ "Return the datestring of the latest ChangeLog entry. The date is determined at compile time." (macrolet ((date () - (let* ((dir (pathname-directory *compile-file-pathname*)) - (changelog (make-pathname :name "ChangeLog" :directory dir - :host (pathname-host - *compile-file-pathname*))) + (let* ((here (or *compile-file-truename* *load-truename*)) + (changelog (make-pathname + :name "ChangeLog" + :directory (pathname-directory here) + :host (pathname-host here))) (date (with-open-file (file changelog :direction :input) (string (read file))))) `(quote ,date)))) @@ -318,12 +320,13 @@ (defun current-socket-io () (connection.socket-io (current-connection))) -(defmacro with-a-connection (() &body body) +(defmacro with-a-connection ((&rest ignore) &body body) "Execute BODY with a connection. If no connection is currently available then a new one is temporarily created for the extent of the execution. Thus the BODY forms can call READ-FROM-EMACS and SEND-TO-EMACS." + (declare (ignore ignore)) `(if (current-connection) (progn , at body) (call-with-aux-connection (lambda () , at body)))) From heller at common-lisp.net Fri Jan 16 07:28:24 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 02:28:24 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14092 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 16 02:28:23 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.209 slime/ChangeLog:1.210 --- slime/ChangeLog:1.209 Fri Jan 16 01:51:15 2004 +++ slime/ChangeLog Fri Jan 16 02:28:23 2004 @@ -1,3 +1,11 @@ +2004-01-16 Helmut Eller + + * swank.lisp (changelog-date): Use *compile-file-truename* instead + of *compile-file-pathname*. + (with-I/O-lock, with-a-connection): The usual CLISP fixes. + + * slime.el: Numerous REPL related fixes. + 2004-01-16 Luke Gorrie * swank-openmcl.lisp: Multiprocessing support. From heller at common-lisp.net Fri Jan 16 21:24:51 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 16:24:51 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22509 Modified Files: slime.el Log Message: (slime-update-state-name): Take state as argument. (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Fix typos. (sldb-insert-restarts): Remove duplicate definition. Date: Fri Jan 16 16:24:51 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.179 slime/slime.el:1.180 --- slime/slime.el:1.179 Fri Jan 16 02:23:59 2004 +++ slime/slime.el Fri Jan 16 16:24:51 2004 @@ -1367,10 +1367,10 @@ the state name for the modeline." (let ((state (slime-current-state))) (when (eq (slime-connection) slime-default-connection) - (slime-update-state-name)) + (slime-update-state-name state)) (slime-dispatch-event '(activate)))) -(defun slime-update-state-name () +(defun slime-update-state-name (state) (slime-with-connection-buffer (slime-default-connection) (setq slime-state-name (ecase (slime-state-name state) @@ -2069,14 +2069,14 @@ (defun slime-repl-beginning-of-defun () "Move to beginning of defun." (interactive) - (if (slime-in-input-area-p) + (if (slime-repl-in-input-area-p) (goto-char slime-repl-input-start-mark) (beginning-of-defun))) (defun slime-repl-end-of-defun () "Move to next of defun." (interactive) - (if (slime-in-input-area-p) + (if (slime-repl-in-input-area-p) (goto-char slime-repl-input-end-mark) (end-of-defun))) @@ -2962,7 +2962,7 @@ slime-autodoc-mode (null (current-message)) (not executing-kbd-macro) - (not (and (boundp 'edebug-active) edebug-active)) + (not (and (boundp 'edebug-active) (symbol-value 'edebug-active))) (not cursor-in-echo-area) (not (eq (selected-window) (minibuffer-window))) (slime-connected-p) @@ -3984,21 +3984,6 @@ (in-sldb-face condition type) "\n\n"))) -(defun sldb-insert-restarts (restarts) - (loop for (name string) in restarts - for number from 0 - do (progn - (slime-insert-propertized - `(restart-number ,number - sldb-default-action sldb-invoke-restart - mouse-face highlight) - " " (in-sldb-face restart-number - (number-to-string number)) - ": [" (in-sldb-face restart-type name) "] " - (in-sldb-face restart string)) - (insert "\n"))) - (insert "\n")) - (defun sldb-setup (condition restarts frames) "Setup a new SLDB buffer. CONDITION is a string describing the condition to debug. @@ -5373,6 +5358,7 @@ slime-events-buffer slime-output-string slime-output-buffer + slime-output-filter slime-with-output-end-mark ;; Compilation warns due to runtime call to a `cl' function. Annoying. ;; slime-process-available-input From heller at common-lisp.net Fri Jan 16 21:29:01 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 16:29:01 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10689 Modified Files: swank.lisp Log Message: (create-swank-server): Patch by Marco Baringer . Bring it back again. (create-connection): Use return the dedicated output stream if available. Date: Fri Jan 16 16:29:00 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.100 slime/swank.lisp:1.101 --- slime/swank.lisp:1.100 Fri Jan 16 02:26:13 2004 +++ slime/swank.lisp Fri Jan 16 16:28:59 2004 @@ -136,9 +136,9 @@ ;; This can't be initialized right away due to our compilation/loading ;; order: it ends up calling the NO-APPLICABLE-METHOD version from ;; swank-backend before the real one loads. -(makunbound - (defvar *write-lock* nil - "Lock held while writing to sockets.")) +(defvar *write-lock*) +(setf (documentation '*write-lock* 'variable) + "Lock held while writing to sockets.") (defvar *dispatching-connection* nil "Connection currently being served. @@ -175,16 +175,24 @@ (defvar *use-dedicated-output-stream* t) (defvar *swank-in-background* nil) -(defun start-server (port-file) +(defun start-server (port-file &optional (background *swank-in-background*)) + (setup-server 0 (lambda (port) (announce-server-port port-file port)) + background)) + +(defun create-swank-server (&optional (port 4005) + (background *swank-in-background*)) + (setup-server port #'simple-announce-function background)) + +(defun setup-server (port announce-fn background) (setq *write-lock* (make-lock :name "Swank write lock")) (if (eq *swank-in-background* :spawn) - (spawn (lambda () (setup-server port-file nil)) + (spawn (lambda () (open-swank-socket port announce-fn nil)) :name "Swank") - (setup-server port-file *swank-in-background*))) + (open-swank-socket port announce-fn background))) -(defun setup-server (port-file background) - (let ((socket (create-socket 0))) - (announce-server-port port-file (local-port socket)) +(defun open-swank-socket (port announce-fn background) + (let ((socket (create-socket port))) + (funcall announce-fn (local-port socket)) (let ((client (accept-connection socket))) (close-socket socket) (let ((connection (create-connection client))) @@ -221,9 +229,10 @@ (make-output-function socket-io) (let ((input-fn (lambda () (read-user-input-from-emacs socket-io)))) (multiple-value-bind (in out) (make-fn-streams input-fn output-fn) - (let ((io (make-two-way-stream in out))) - (make-connection (thread-id) socket-io dedicated-output - in out io)))))) + (let ((out (or dedicated-output out))) + (let ((io (make-two-way-stream in out))) + (make-connection (thread-id) socket-io dedicated-output + in out io))))))) (defun make-output-function (socket-io) "Create function to send user output to Emacs. From heller at common-lisp.net Fri Jan 16 21:32:14 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 16:32:14 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9092 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 16 16:32:13 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.210 slime/ChangeLog:1.211 --- slime/ChangeLog:1.210 Fri Jan 16 02:28:23 2004 +++ slime/ChangeLog Fri Jan 16 16:32:13 2004 @@ -3,8 +3,16 @@ * swank.lisp (changelog-date): Use *compile-file-truename* instead of *compile-file-pathname*. (with-I/O-lock, with-a-connection): The usual CLISP fixes. + (create-swank-server): Patch by Marco Baringer . + Bring it back again. + (create-connection): Use return the dedicated output stream if + available. * slime.el: Numerous REPL related fixes. + (slime-update-state-name): Take state as argument. + (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Fix + typos. + (sldb-insert-restarts): Remove duplicate definition. 2004-01-16 Luke Gorrie From heller at common-lisp.net Fri Jan 16 21:49:30 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 16:49:30 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp slime/swank-cmucl.lisp slime/swank-openmcl.lisp slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv6976 Modified Files: swank.lisp swank-cmucl.lisp swank-openmcl.lisp swank-backend.lisp Log Message: Refactor inspector code. Date: Fri Jan 16 16:49:30 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.101 slime/swank.lisp:1.102 --- slime/swank.lisp:1.101 Fri Jan 16 16:28:59 2004 +++ slime/swank.lisp Fri Jan 16 16:49:29 2004 @@ -1084,7 +1084,8 @@ (defslimefun throw-to-toplevel () (throw 'slime-toplevel nil)) -;;; Source Locations + +;;;; Source Locations (defstruct (:location (:type list) :named (:constructor make-location (buffer position))) @@ -1133,6 +1134,106 @@ (if errors `(("Unresolved" . ,errors)))))))) + +;;;; Inspecting + +(defvar *inspectee*) +(defvar *inspectee-parts*) +(defvar *inspector-stack* '()) +(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) +(defvar *inspect-length* 30) + +(defun reset-inspector () + (setq *inspectee* nil) + (setq *inspectee-parts* nil) + (setq *inspector-stack* nil) + (setf (fill-pointer *inspector-history*) 0)) + +(defslimefun init-inspector (string) + (reset-inspector) + (inspect-object (eval (from-string string)))) + +(defun print-part-to-string (value) + (let ((*print-pretty* nil)) + (let ((string (to-string value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "#~D=~A" pos string) + string)))) + +(defun inspect-object (object) + (push (setq *inspectee* object) *inspector-stack*) + (unless (find object *inspector-history*) + (vector-push-extend object *inspector-history*)) + (multiple-value-bind (text parts) (inspected-parts object) + (setq *inspectee-parts* parts) + (list :text text + :type (to-string (type-of object)) + :primitive-type (describe-primitive-type object) + :parts (loop for (label . value) in parts + collect (cons label + (print-part-to-string value)))))) + +(defun nth-part (index) + (cdr (nth index *inspectee-parts*))) + +(defslimefun inspect-nth-part (index) + (inspect-object (nth-part index))) + +(defslimefun inspector-pop () + "Drop the inspector stack and inspect the second element. Return +nil if there's no second element." + (cond ((cdr *inspector-stack*) + (pop *inspector-stack*) + (inspect-object (pop *inspector-stack*))) + (t nil))) + +(defslimefun inspector-next () + "Inspect the next element in the *inspector-history*." + (let ((position (position *inspectee* *inspector-history*))) + (cond ((= (1+ position) (length *inspector-history*)) + nil) + (t (inspect-object (aref *inspector-history* (1+ position))))))) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (print-description-to-string *inspectee*)) + +(defmethod inspected-parts ((object cons)) + (if (consp (cdr object)) + (inspected-parts-of-nontrivial-list object) + (inspected-parts-of-simple-cons object))) + +(defun inspected-parts-of-simple-cons (object) + (values "The object is a CONS." + (list (cons (string 'car) (car object)) + (cons (string 'cdr) (cdr object))))) + +(defun inspected-parts-of-nontrivial-list (object) + (let ((length 0) + (in-list object) + (reversed-elements nil)) + (flet ((done (description-format) + (return-from inspected-parts-of-nontrivial-list + (values (format nil description-format length) + (nreverse reversed-elements))))) + (loop + (cond ((null in-list) + (done "The object is a proper list of length ~S.~%")) + ((>= length *inspect-length*) + (push (cons (string 'rest) in-list) reversed-elements) + (done "The object is a long list (more than ~S elements).~%")) + ((consp in-list) + (push (cons (format nil "~D" length) (pop in-list)) + reversed-elements) + (incf length)) + (t + (push (cons (string 'rest) in-list) reversed-elements) + (done "The object is an improper list of length ~S.~%"))))))) ;;; Local Variables: ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face)))) Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.50 slime/swank-cmucl.lisp:1.51 --- slime/swank-cmucl.lisp:1.50 Thu Jan 15 13:30:30 2004 +++ slime/swank-cmucl.lisp Fri Jan 16 16:49:29 2004 @@ -1072,42 +1072,6 @@ ;;;; Inspecting -(defvar *inspectee*) -(defvar *inspectee-parts*) -(defvar *inspector-stack* '()) -(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) -(defvar *inspect-length* 30) - -(defun reset-inspector () - (setq *inspectee* nil) - (setq *inspectee-parts* nil) - (setq *inspector-stack* nil) - (setf (fill-pointer *inspector-history*) 0)) - -(defslimefun init-inspector (string) - (reset-inspector) - (inspect-object (eval (from-string string)))) - -(defun print-part-to-string (value) - (let ((*print-pretty* nil)) - (let ((string (to-string value)) - (pos (position value *inspector-history*))) - (if pos - (format nil "#~D=~A" pos string) - string)))) - -(defun inspect-object (object) - (push (setq *inspectee* object) *inspector-stack*) - (unless (find object *inspector-history*) - (vector-push-extend object *inspector-history*)) - (multiple-value-bind (text parts) (inspected-parts object) - (setq *inspectee-parts* parts) - (list :text text - :type (to-string (type-of object)) - :primitive-type (describe-primitive-type object) - :parts (loop for (label . value) in parts - collect (cons label - (print-part-to-string value)))))) (defconstant +lowtag-symbols+ '(vm:even-fixnum-type vm:function-pointer-type @@ -1132,7 +1096,7 @@ (append (apropos-list "-TYPE" "VM" t) (apropos-list "-TYPE" "BIGNUM" t))))) -(defun describe-primitive-type (object) +(defmethod describe-primitive-type (object) (with-output-to-string (*standard-output*) (let* ((lowtag (kernel:get-lowtag object)) (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) @@ -1148,39 +1112,6 @@ (format t ", type: ~A]" type-symbol))) (t (format t "]")))))) -(defun nth-part (index) - (cdr (nth index *inspectee-parts*))) - -(defslimefun inspect-nth-part (index) - (inspect-object (nth-part index))) - -(defslimefun inspector-pop () - "Drop the inspector stack and inspect the second element. Return -nil if there's no second element." - (cond ((cdr *inspector-stack*) - (pop *inspector-stack*) - (inspect-object (pop *inspector-stack*))) - (t nil))) - -(defslimefun inspector-next () - "Inspect the next element in the *inspector-history*." - (let ((position (position *inspectee* *inspector-history*))) - (cond ((= (1+ position) (length *inspector-history*)) - nil) - (t (inspect-object (aref *inspector-history* (1+ position))))))) - -(defslimefun quit-inspector () - (reset-inspector) - nil) - -(defslimefun describe-inspectee () - "Describe the currently inspected object." - (print-description-to-string *inspectee*)) - -(defgeneric inspected-parts (object) - (:documentation - "Return a short description and a list of (label . value) pairs.")) - (defmethod inspected-parts (o) (cond ((di::indirect-value-cell-p o) (inspected-parts-of-value-cell o)) @@ -1194,43 +1125,6 @@ for i from 0 collect (cons (format nil "~D" i) value))))) (values text parts)))))) - -(defun inspected-parts-of-value-cell (o) - (values (format nil "~A~% is a value cell." o) - (list (cons "Value" (c:value-cell-ref o))))) - -;; borrowed from sbcl -(defmethod inspected-parts ((object cons)) - (if (consp (cdr object)) - (inspected-parts-of-nontrivial-list object) - (inspected-parts-of-simple-cons object))) - -(defun inspected-parts-of-simple-cons (object) - (values "The object is a CONS." - (list (cons (string 'car) (car object)) - (cons (string 'cdr) (cdr object))))) - -(defun inspected-parts-of-nontrivial-list (object) - (let ((length 0) - (in-list object) - (reversed-elements nil)) - (flet ((done (description-format) - (return-from inspected-parts-of-nontrivial-list - (values (format nil description-format length) - (nreverse reversed-elements))))) - (loop - (cond ((null in-list) - (done "The object is a proper list of length ~S.~%")) - ((>= length *inspect-length*) - (push (cons (string 'rest) in-list) reversed-elements) - (done "The object is a long list (more than ~S elements).~%")) - ((consp in-list) - (push (cons (format nil "~D" length) (pop in-list)) - reversed-elements) - (incf length)) - (t - (push (cons (string 'rest) in-list) reversed-elements) - (done "The object is an improper list of length ~S.~%"))))))) (defmethod inspected-parts ((o function)) (let ((header (kernel:get-type o))) Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.48 slime/swank-openmcl.lisp:1.49 --- slime/swank-openmcl.lisp:1.48 Fri Jan 16 02:10:29 2004 +++ slime/swank-openmcl.lisp Fri Jan 16 16:49:29 2004 @@ -514,84 +514,6 @@ ;;; Macroexpansion (defslimefun-unimplemented swank-macroexpand-all (string)) - -;;;; Inspecting - -;;XXX refactor common code. - -(defvar *inspectee*) -(defvar *inspectee-parts*) -(defvar *inspector-stack* '()) -(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) -(defvar *inspect-length* 30) - -(defun reset-inspector () - (setq *inspectee* nil) - (setq *inspectee-parts* nil) - (setq *inspector-stack* nil) - (setf (fill-pointer *inspector-history*) 0)) - -(defslimefun init-inspector (string) - (reset-inspector) - (inspect-object (eval (from-string string)))) - -(defun print-part-to-string (value) - (let ((*print-pretty* nil)) - (let ((string (to-string value)) - (pos (position value *inspector-history*))) - (if pos - (format nil "#~D=~A" pos string) - string)))) - -(defun inspect-object (object) - (push (setq *inspectee* object) *inspector-stack*) - (unless (find object *inspector-history*) - (vector-push-extend object *inspector-history*)) - (multiple-value-bind (text parts) (inspected-parts object) - (setq *inspectee-parts* parts) - (list :text text - :type (to-string (type-of object)) - :primitive-type (describe-primitive-type object) - :parts (loop for (label . value) in parts - collect (cons label - (print-part-to-string value)))))) - -(defun nth-part (index) - (cdr (nth index *inspectee-parts*))) - -(defslimefun inspect-nth-part (index) - (inspect-object (nth-part index))) - -(defslimefun inspector-pop () - "Drop the inspector stack and inspect the second element. Return -nil if there's no second element." - (cond ((cdr *inspector-stack*) - (pop *inspector-stack*) - (inspect-object (pop *inspector-stack*))) - (t nil))) - -(defslimefun inspector-next () - "Inspect the next element in the *inspector-history*." - (let ((position (position *inspectee* *inspector-history*))) - (cond ((= (1+ position) (length *inspector-history*)) - nil) - (t (inspect-object (aref *inspector-history* (1+ position))))))) - -(defslimefun quit-inspector () - (reset-inspector) - nil) - -(defslimefun describe-inspectee () - "Describe the currently inspected object." - (print-description-to-string *inspectee*)) - -(defgeneric inspected-parts (object) - (:documentation - "Return a short description and a list of (label . value) pairs.")) - -;;&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -;; specific to openmcl - (defvar *value2tag* (make-hash-table)) (do-symbols (s (find-package 'arch)) @@ -602,7 +524,7 @@ (< (symbol-value s) 255)) (setf (gethash (symbol-value s) *value2tag*) s))) -(defun describe-primitive-type (thing) +(defmethod describe-primitive-type (thing) (let ((typecode (ccl::typecode thing))) (if (gethash typecode *value2tag*) (string (gethash typecode *value2tag*)) @@ -630,40 +552,6 @@ (defslimefun inspect-in-frame (string index) (reset-inspector) (inspect-object (eval-in-frame (from-string string) index))) - -;;&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - -(defmethod inspected-parts ((object cons)) - (if (consp (cdr object)) - (inspected-parts-of-nontrivial-list object) - (inspected-parts-of-simple-cons object))) - -(defun inspected-parts-of-simple-cons (object) - (values "The object is a CONS." - (list (cons (string 'car) (car object)) - (cons (string 'cdr) (cdr object))))) - -(defun inspected-parts-of-nontrivial-list (object) - (let ((length 0) - (in-list object) - (reversed-elements nil)) - (flet ((done (description-format) - (return-from inspected-parts-of-nontrivial-list - (values (format nil description-format length) - (nreverse reversed-elements))))) - (loop - (cond ((null in-list) - (done "The object is a proper list of length ~S.~%")) - ((>= length *inspect-length*) - (push (cons (string 'rest) in-list) reversed-elements) - (done "The object is a long list (more than ~S elements).~%")) - ((consp in-list) - (push (cons (format nil "~D" length) (pop in-list)) - reversed-elements) - (incf length)) - (t - (push (cons (string 'rest) in-list) reversed-elements) - (done "The object is an improper list of length ~S.~%"))))))) ;;; Multiprocessing Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.18 slime/swank-backend.lisp:1.19 --- slime/swank-backend.lisp:1.18 Thu Jan 15 13:15:00 2004 +++ slime/swank-backend.lisp Fri Jan 16 16:49:29 2004 @@ -384,6 +384,17 @@ ")) +;;;; Inspector + +(defgeneric inspected-parts (object) + (:documentation + "Return a short description and a list of (LABEL . VALUE) pairs.")) + +(defgeneric describe-primitive-type (object) + (:documentation + "Return a string describing the primitive type of object.")) + + ;;;; Multiprocessing (defgeneric startup-multiprocessing () From heller at common-lisp.net Fri Jan 16 21:51:01 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 16:51:01 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv18125 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 16 16:51:00 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.211 slime/ChangeLog:1.212 --- slime/ChangeLog:1.211 Fri Jan 16 16:32:13 2004 +++ slime/ChangeLog Fri Jan 16 16:51:00 2004 @@ -1,5 +1,8 @@ 2004-01-16 Helmut Eller + * swank-openmcl.lisp, swank-cmucl.lisp, swank-backend.lisp, + swank.lisp: Refactor inspector code. + * swank.lisp (changelog-date): Use *compile-file-truename* instead of *compile-file-pathname*. (with-I/O-lock, with-a-connection): The usual CLISP fixes. From heller at common-lisp.net Fri Jan 16 21:54:22 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 16:54:22 -0500 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26400 Modified Files: swank-allegro.lisp Log Message: Add multiprocessing support. Date: Fri Jan 16 16:54:21 2004 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.7 slime/swank-allegro.lisp:1.8 --- slime/swank-allegro.lisp:1.7 Thu Jan 15 13:29:22 2004 +++ slime/swank-allegro.lisp Fri Jan 16 16:54:21 2004 @@ -1,4 +1,4 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- ;;; ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME. ;;; @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.7 2004/01/15 18:29:22 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.8 2004/01/16 21:54:21 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -35,7 +35,7 @@ (defun without-interrupts* (body) (excl:without-interrupts (funcall body))) -;;; TCP Server +;;;; TCP Server (defmethod create-socket (port) (socket:make-socket :connect :passive :local-port port :reuse-address t)) @@ -49,12 +49,12 @@ (defmethod accept-connection (socket) (socket:accept-connection socket :wait t)) -(defmethod spawn (fn &key name) - (mp:process-run-function name fn)) - (defmethod emacs-connected ()) -;;; +(defslimefun getpid () + (excl::getpid)) + +;;;; Misc (defmethod arglist-string (fname) (declare (type string fname)) @@ -67,9 +67,6 @@ (cond (condition (format nil "(-- ~A)" condition)) (t (format nil "(~{~A~^ ~})" arglist)))))) -(defslimefun getpid () - (excl::getpid)) - (defun apropos-symbols (string &optional external-only package) (remove-if (lambda (sym) (or (keywordp sym) @@ -99,6 +96,8 @@ (defmethod macroexpand-all (form) (excl::walk form)) +;;;; Debugger + (defvar *sldb-topframe*) (defvar *sldb-source*) (defvar *sldb-restarts*) @@ -171,6 +170,8 @@ (list :error (format nil "Cannot find source for frame: ~A" (nth-frame index)))) +;;;; Compiler hooks + (defvar *buffer-name* nil) (defvar *buffer-start-position*) (defvar *buffer-string*) @@ -211,6 +212,8 @@ (eval (from-string (format nil "(funcall (compile nil '(lambda () ~A)))" string)))))) +;;;; Definition Finding + (defun fspec-source-locations (fspec) (let ((defs (excl::find-multiple-definitions fspec))) (let ((locations '())) @@ -251,6 +254,8 @@ (format nil "Symbol not fbound: ~A" symbol-name)))) ))) +;;;; XREF + (defun lookup-xrefs (finder name) (xref-results-for-emacs (funcall finder (from-string name)))) @@ -285,3 +290,23 @@ (push (cons (to-string fspec) location) xrefs))) (group-xrefs xrefs))) +;;;; Multiprocessing + +(defmethod startup-multiprocessing () + (mp:start-scheduler)) + +(defmethod spawn (fn &key name) + (mp:process-run-function name fn)) + +;; XXX: shurtcut +(defmethod thread-id () + (mp:process-name mp:*current-process*)) + +(defmethod thread-name (thread-id) + thread-id) + +(defmethod make-lock (&key name) + (mp:make-process-lock :name name)) + +(defmethod call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) From heller at common-lisp.net Fri Jan 16 21:54:54 2004 From: heller at common-lisp.net (Helmut Eller) Date: Fri, 16 Jan 2004 16:54:54 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28032 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Fri Jan 16 16:54:54 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.212 slime/ChangeLog:1.213 --- slime/ChangeLog:1.212 Fri Jan 16 16:51:00 2004 +++ slime/ChangeLog Fri Jan 16 16:54:54 2004 @@ -1,5 +1,7 @@ 2004-01-16 Helmut Eller + * swank-allegro.lisp: Multiprocessing support. + * swank-openmcl.lisp, swank-cmucl.lisp, swank-backend.lisp, swank.lisp: Refactor inspector code. From heller at common-lisp.net Sat Jan 17 09:59:48 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 17 Jan 2004 04:59:48 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20688 Modified Files: swank-cmucl.lisp Log Message: (arglist-string): Handle generic functions better. Reported by Ivan Boldyrev. Date: Sat Jan 17 04:59:48 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.51 slime/swank-cmucl.lisp:1.52 --- slime/swank-cmucl.lisp:1.51 Fri Jan 16 16:49:29 2004 +++ slime/swank-cmucl.lisp Sat Jan 17 04:59:48 2004 @@ -28,7 +28,8 @@ (ext:close-socket (socket-fd socket))) (defmethod accept-connection (socket) - #+MP (when *multiprocessing-enabled* (mp:process-wait-until-fd-usable socket :input)) + #+MP (when *multiprocessing-enabled* + (mp:process-wait-until-fd-usable socket :input)) (make-socket-io-stream (ext:accept-tcp-connection socket))) (defmethod add-input-handler (socket fn) @@ -781,7 +782,7 @@ (cond ((eval:interpreted-function-p fun) (eval:interpreted-function-arglist fun)) ((pcl::generic-function-p fun) - (pcl::gf-pretty-arglist fun)) + (pcl::arg-info-lambda-list (pcl::gf-arg-info fun))) (arglist arglist) ;; this should work both for ;; compiled-debug-function and for From heller at common-lisp.net Sat Jan 17 10:01:47 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 17 Jan 2004 05:01:47 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv1280 Modified Files: slime.el Log Message: (slime-format-arglist): Add some sanity checks. Suggested by Ivan Boldyrev. (slime-test-expect): Take test predicate as argument. (arglist): Test generic functions. Date: Sat Jan 17 05:01:46 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.180 slime/slime.el:1.181 --- slime/slime.el:1.180 Fri Jan 16 16:24:51 2004 +++ slime/slime.el Sat Jan 17 05:01:46 2004 @@ -2843,7 +2843,8 @@ (lambda (arglist) (if show-fn (funcall show-fn arglist) - (slime-background-message "%s" (slime-format-arglist symbol-name arglist))))))) + (slime-background-message + "%s" (slime-format-arglist symbol-name arglist))))))) (defun slime-get-arglist (symbol-name) "Return the argument list for SYMBOL-NAME." @@ -2851,6 +2852,8 @@ (slime-eval `(swank:arglist-string ,symbol-name)))) (defun slime-format-arglist (symbol-name arglist) + (assert (eq ?\( (aref arglist 0))) + (assert (eq ?\) (aref arglist (1- (length arglist))))) (format "(%s %s)" symbol-name (substring arglist 1 -1))) @@ -4824,9 +4827,9 @@ (slime-check ((or test-name "Automaton in idle state.")) (slime-test-state-stack '(slime-idle-state)))) -(defun slime-test-expect (name expected actual) +(defun slime-test-expect (name expected actual &optional test) (slime-check ("%s:\nexpected: [%S]\n actual: [%S]" name expected actual) - (equal expected actual))) + (funcall (or test equal) expected actual))) (def-slime-test find-definition (name buffer-package) @@ -4875,10 +4878,14 @@ '(("swank:start-server" "(swank:start-server port-file)") ("swank::compound-prefix-match" - "(swank::compound-prefix-match prefix target)")) + "(swank::compound-prefix-match prefix target)") + ("swank::create-socket" + "(swank::create-socket swank::port)") + ("swank::compile-string-for-emacs" + "(swank::compile-string-for-emacs string &key swank::buffer position)")) (let ((arglist (slime-get-arglist function-name))) ; - (slime-check ("Argument list %S is as expected." arglist) - (string= expected-arglist arglist)))) + (slime-test-expect "Argument list is as expected" + expected-arglist arglist))) (def-slime-test compile-defun (program subform) From heller at common-lisp.net Sat Jan 17 10:03:14 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 17 Jan 2004 05:03:14 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv10977 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Jan 17 05:03:14 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.213 slime/ChangeLog:1.214 --- slime/ChangeLog:1.213 Fri Jan 16 16:54:54 2004 +++ slime/ChangeLog Sat Jan 17 05:03:13 2004 @@ -1,3 +1,13 @@ +2004-01-17 Helmut Eller + + * slime.el (slime-format-arglist): Add some sanity checks. + Suggested by Ivan Boldyrev. + (slime-test-expect): Take test predicate as argument. + (arglist): Test generic functions. + + * swank-cmucl.lisp (arglist-string): Handle generic functions + better. Reported by Ivan Boldyrev. + 2004-01-16 Helmut Eller * swank-allegro.lisp: Multiprocessing support. From heller at common-lisp.net Sat Jan 17 10:22:24 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 17 Jan 2004 05:22:24 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv22934 Modified Files: slime.el Log Message: (slime-format-arglist): Nicer handling of zero argument functions. Date: Sat Jan 17 05:22:24 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.181 slime/slime.el:1.182 --- slime/slime.el:1.181 Sat Jan 17 05:01:46 2004 +++ slime/slime.el Sat Jan 17 05:22:24 2004 @@ -2854,7 +2854,11 @@ (defun slime-format-arglist (symbol-name arglist) (assert (eq ?\( (aref arglist 0))) (assert (eq ?\) (aref arglist (1- (length arglist))))) - (format "(%s %s)" symbol-name (substring arglist 1 -1))) + (let ((args (substring arglist 1 -1))) + (format "(%s%s%s)" + symbol-name + (if (zerop (length args)) "" " ") + args))) ;;; Autodocs (automatic context-sensitive help) @@ -4829,7 +4833,7 @@ (defun slime-test-expect (name expected actual &optional test) (slime-check ("%s:\nexpected: [%S]\n actual: [%S]" name expected actual) - (funcall (or test equal) expected actual))) + (funcall (or test #'equal) expected actual))) (def-slime-test find-definition (name buffer-package) @@ -4881,6 +4885,8 @@ "(swank::compound-prefix-match prefix target)") ("swank::create-socket" "(swank::create-socket swank::port)") + ("swank::emacs-connected" + "(swank::emacs-connected)") ("swank::compile-string-for-emacs" "(swank::compile-string-for-emacs string &key swank::buffer position)")) (let ((arglist (slime-get-arglist function-name))) ; From heller at common-lisp.net Sat Jan 17 10:23:19 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 17 Jan 2004 05:23:19 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25795 Modified Files: swank-cmucl.lisp Log Message: (arglist-string): Handle zero argument functions correctly. Date: Sat Jan 17 05:23:19 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.52 slime/swank-cmucl.lisp:1.53 --- slime/swank-cmucl.lisp:1.52 Sat Jan 17 04:59:48 2004 +++ slime/swank-cmucl.lisp Sat Jan 17 05:23:19 2004 @@ -789,9 +789,10 @@ ;; interpreted-debug-function (df (di::debug-function-lambda-list df)) (t "()")))))) - (if (stringp arglist) - arglist - (to-string arglist))))) + (etypecase arglist + (string arglist) + (cons (to-string arglist)) + (null "()"))))) ;;;; Miscellaneous. From heller at common-lisp.net Sat Jan 17 10:35:24 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sat, 17 Jan 2004 05:35:24 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28790 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Jan 17 05:35:24 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.214 slime/ChangeLog:1.215 --- slime/ChangeLog:1.214 Sat Jan 17 05:03:13 2004 +++ slime/ChangeLog Sat Jan 17 05:35:24 2004 @@ -1,7 +1,7 @@ 2004-01-17 Helmut Eller - * slime.el (slime-format-arglist): Add some sanity checks. - Suggested by Ivan Boldyrev. + * slime.el (slime-format-arglist): Add some sanity checks and + print zero argument functions nicer. Suggested by Ivan Boldyrev. (slime-test-expect): Take test predicate as argument. (arglist): Test generic functions. From wjenkner at common-lisp.net Sun Jan 18 05:47:39 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Sun, 18 Jan 2004 00:47:39 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30856 Modified Files: swank-clisp.lisp Log Message: (compile-file-for-emacs, split-compiler-note-line): Revert last change. (handle-notification-condition): Don't signal the condition. (*compiler-note-line-regexp*): Fix and rewrite it as extended regexp. Date: Sun Jan 18 00:47:39 2004 Author: wjenkner Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.10 slime/swank-clisp.lisp:1.11 --- slime/swank-clisp.lisp:1.10 Wed Jan 14 18:43:16 2004 +++ slime/swank-clisp.lisp Sun Jan 18 00:47:39 2004 @@ -320,55 +320,61 @@ (defun handle-notification-condition (condition) "Handle a condition caused by a compiler warning." - (signal condition)) + (declare (ignore condition))) (defvar *buffer-name* nil) (defvar *buffer-offset*) (defvar *compiler-note-line-regexp* (regexp:regexp-compile - "^\\(WARNING\\|ERROR\\) .* in lines \\([0-9]\\+\\)..[0-9]\\+ :$")) + "^(WARNING|ERROR) .* in lines ([0-9]+)\\.\\.[0-9]+ :$" + :extended t)) (defun split-compiler-note-line (line) (multiple-value-bind (all head tail) (regexp:regexp-exec *compiler-note-line-regexp* line) (declare (ignore all)) (if head - (values (let ((*package* (find-package :keyword))) - (read-from-string (regexp:match-string line head))) - (read-from-string (regexp:match-string line tail))) - (values nil line)))) + (list (let ((*package* (find-package :keyword))) + (read-from-string (regexp:match-string line head))) + (read-from-string (regexp:match-string line tail))) + (list nil line)))) ;;; Ugly but essentially working. -;;; FIXME: I get all notes twice. +;;; TODO: Do something with the summary about undefined functions etc. (defmethod compile-file-for-emacs (filename load-p) (with-compilation-hooks () - (multiple-value-bind (fasl-file w-p f-p) + (multiple-value-bind (fas-file w-p f-p) (compile-file-frobbing-notes (filename) (read-line) ;"" (read-line) ;"Compiling file ..." - (do ((condition) - (severity) - (comp-message)) - ((and (stringp comp-message) (string= comp-message "")) t) - (multiple-value-setq (severity comp-message) - (split-compiler-note-line (read-line))) - (when severity - (setq condition - (make-condition 'compiler-condition - :severity severity - :message "" - :location `(:location (:file ,filename) - (:line ,comp-message)))) - (setf (message condition) - (format nil "~a~&~a" (message condition) comp-message)) - (signal condition)))) - (declare (ignore w-p)) - (if (and (not (not f-p)) fasl-file load-p) -;;;!!! CLISP provides a fixnum for failure-p and warning-p for compile-file - (load fasl-file) - fasl-file)))) + (loop + with condition + for (severity message) = (split-compiler-note-line (read-line)) + until (and (stringp message) (string= message "")) + if severity + do (when condition + (signal condition)) + (setq condition + (make-condition 'compiler-condition + :severity severity + :message "" + :location `(:location (:file ,filename) + (:line ,message)))) + else do (setf (message condition) + (format nil "~a~&~a" (message condition) message)) + finally (when condition + (signal condition)))) + ;; w-p = errors + warnings, f-p = errors + warnings - style warnings, + ;; where a result of 0 is replaced by NIL. It follows that w-p + ;; is T iff there was any note whatsoever and that f-p is T iff + ;; there was anything more severe than a style warning. This is + ;; completely ANSI compliant. + (declare (ignore w-p f-p)) + (if (and fas-file load-p) + (load fas-file) + fas-file)))) (defmethod compile-string-for-emacs (string &key buffer position) (with-compilation-hooks () From wjenkner at common-lisp.net Sun Jan 18 05:52:09 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Sun, 18 Jan 2004 00:52:09 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv19904 Modified Files: slime.el Log Message: (slime-changelog-date): Use file-truename of byte-compile-current-file. Date: Sun Jan 18 00:52:09 2004 Author: wjenkner Index: slime/slime.el diff -u slime/slime.el:1.182 slime/slime.el:1.183 --- slime/slime.el:1.182 Sat Jan 17 05:22:24 2004 +++ slime/slime.el Sun Jan 18 00:52:08 2004 @@ -978,7 +978,8 @@ (macrolet ((date () (let* ((dir (or (and byte-compile-current-file (file-name-directory - byte-compile-current-file)) + (file-truename + byte-compile-current-file))) slime-path)) (file (concat dir "ChangeLog")) (date (with-temp-buffer From wjenkner at common-lisp.net Sun Jan 18 05:53:36 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Sun, 18 Jan 2004 00:53:36 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv21792 Modified Files: ChangeLog Log Message: Date: Sun Jan 18 00:53:35 2004 Author: wjenkner Index: slime/ChangeLog diff -u slime/ChangeLog:1.215 slime/ChangeLog:1.216 --- slime/ChangeLog:1.215 Sat Jan 17 05:35:24 2004 +++ slime/ChangeLog Sun Jan 18 00:53:35 2004 @@ -1,3 +1,14 @@ +2004-01-18 Wolfgang Jenkner + + * swank-clisp.lisp (compile-file-for-emacs, + split-compiler-note-line): Revert last change. + (handle-notification-condition): Don't signal the condition. + (*compiler-note-line-regexp*): Fix and rewrite it as extended + regexp. + + * slime.el (slime-changelog-date): Use file-truename of + byte-compile-current-file. + 2004-01-17 Helmut Eller * slime.el (slime-format-arglist): Add some sanity checks and From heller at common-lisp.net Sun Jan 18 07:10:22 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:10:22 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv25989 Modified Files: swank-cmucl.lisp Log Message: (arglist-string): Use pcl:generic-function-lambda-list for generic functions. Handle closures. Print arglist in lower case. Date: Sun Jan 18 02:10:21 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.53 slime/swank-cmucl.lisp:1.54 --- slime/swank-cmucl.lisp:1.53 Sat Jan 17 05:23:19 2004 +++ slime/swank-cmucl.lisp Sun Jan 18 02:10:21 2004 @@ -4,9 +4,6 @@ (in-package :swank) -(defun without-interrupts* (body) - (sys:without-interrupts (funcall body))) - ;;;; TCP server. @@ -47,10 +44,6 @@ (input (make-slime-input-stream input-fn output))) (values input output))) -(defmethod spawn (fn &key (name "Anonymous")) - (mp:make-process fn :name name)) - -;;; ;;;;; Socket helpers. (defun socket-fd (socket) @@ -78,6 +71,15 @@ (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK))))) +;;;; Unix signals + +(defmethod call-without-interrupts (fn) + (sys:without-interrupts (funcall fn))) + +(defmethod getpid () + (unix:unix-getpid)) + + ;;;; Stream handling (defstruct (slime-output-stream @@ -767,10 +769,9 @@ "Return a string describing the argument list for FNAME. The result has the format \"(...)\"." (declare (type string fname)) - (multiple-value-bind (function condition) - (ignore-errors (values (find-symbol-designator fname *buffer-package*))) - (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) + (multiple-value-bind (function package) (find-symbol-designator fname) + (unless package + (return-from arglist-string (format nil "(-- Unkown symbol: ~A)" fname))) (let ((arglist (if (not (or (fboundp function) (functionp function))) @@ -778,11 +779,12 @@ (let* ((fun (or (macro-function function) (symbol-function function))) (df (di::function-debug-function fun)) - (arglist (kernel:%function-arglist fun))) + (arglist (kernel:%function-arglist + (kernel:%function-self fun)))) (cond ((eval:interpreted-function-p fun) (eval:interpreted-function-arglist fun)) ((pcl::generic-function-p fun) - (pcl::arg-info-lambda-list (pcl::gf-arg-info fun))) + (pcl:generic-function-lambda-list fun)) (arglist arglist) ;; this should work both for ;; compiled-debug-function and for @@ -791,7 +793,7 @@ (t "()")))))) (etypecase arglist (string arglist) - (cons (to-string arglist)) + (cons (let ((*print-case* :downcase)) (princ-to-string arglist))) (null "()"))))) @@ -898,9 +900,6 @@ (safe-definition-finding (source-location-from-code-location code-location))) -(defslimefun getpid () - (unix:unix-getpid)) - ;;;; Debugging @@ -1178,6 +1177,9 @@ ;; Threads magic: this never returns! But top-level becomes ;; available again. (mp::startup-idle-and-top-level-loops)) + + (defmethod spawn (fn &key (name "Anonymous")) + (mp:make-process fn :name name)) (defmethod thread-id () (mp:without-scheduling From heller at common-lisp.net Sun Jan 18 07:11:39 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:11:39 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26976 Modified Files: slime.el Log Message: (arglist): Test slot readers and closures. Date: Sun Jan 18 02:11:39 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.183 slime/slime.el:1.184 --- slime/slime.el:1.183 Sun Jan 18 00:52:08 2004 +++ slime/slime.el Sun Jan 18 02:11:39 2004 @@ -4885,11 +4885,15 @@ ("swank::compound-prefix-match" "(swank::compound-prefix-match prefix target)") ("swank::create-socket" - "(swank::create-socket swank::port)") + "(swank::create-socket port)") ("swank::emacs-connected" "(swank::emacs-connected)") ("swank::compile-string-for-emacs" - "(swank::compile-string-for-emacs string &key swank::buffer position)")) + "(swank::compile-string-for-emacs string &key buffer position)") + ("swank::connection.owner-id" + "(swank::connection.owner-id structure)") + ("cl:class-name" + "(cl:class-name class)")) (let ((arglist (slime-get-arglist function-name))) ; (slime-test-expect "Argument list is as expected" expected-arglist arglist))) From heller at common-lisp.net Sun Jan 18 07:15:49 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:15:49 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-lispworks.lisp slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17429 Modified Files: swank-backend.lisp swank-sbcl.lisp swank-openmcl.lisp swank-lispworks.lisp swank-clisp.lisp Log Message: (arglist-string): Refactor common code to swank.lisp. (call-without-interrupts, getpid): Are now generic functions. Date: Sun Jan 18 02:15:49 2004 Author: heller Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.19 slime/swank-backend.lisp:1.20 --- slime/swank-backend.lisp:1.19 Fri Jan 16 16:49:29 2004 +++ slime/swank-backend.lisp Sun Jan 18 02:15:49 2004 @@ -132,6 +132,17 @@ nil) +;;;; Unix signals + +(defconstant +sigint+ 2) + +(defgeneric call-without-interrupts (fn) + (:documentation "Call FN in a context where interrupts are disabled.")) + +(defgeneric getpid () + (:documentation "Return the (Unix) process ID of this superior Lisp.")) + + ;;;; Compilation (defgeneric call-with-compilation-hooks (func) Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.51 slime/swank-sbcl.lisp:1.52 --- slime/swank-sbcl.lisp:1.51 Thu Jan 15 13:31:04 2004 +++ slime/swank-sbcl.lisp Sun Jan 18 02:15:49 2004 @@ -56,9 +56,6 @@ sb-gray:stream-line-column sb-gray:stream-line-length)) -(defun without-interrupts* (body) - (sb-sys:without-interrupts (funcall body))) - ;;; TCP Server (setq *swank-in-background* :fd-handler) @@ -117,6 +114,12 @@ :output-stream output))) (values input output))) +(defmethod call-without-interrupts (fn) + (sb-sys:without-interrupts (funcall fn))) + +(defmethod getpid () + (sb-unix:unix-getpid)) + ;;; Utilities (defvar *swank-debugger-stack-frame*) @@ -127,17 +130,7 @@ (namestring *default-pathname-defaults*)) (defmethod arglist-string (fname) - (let ((*print-case* :downcase)) - (multiple-value-bind (function condition) - (ignore-errors (values - (find-symbol-designator fname *buffer-package*))) - (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) - (let ((arglist - (ignore-errors (sb-introspect:function-arglist function)))) - (if arglist - (princ-to-string arglist) - "(-- )"))))) + (format-arglist fname #'sb-introspect:function-arglist)) (defvar *buffer-name* nil) (defvar *buffer-offset*) @@ -384,12 +377,6 @@ (defmethod macroexpand-all (form) (let ((sb-walker:*walk-form-expand-macros-p* t)) (sb-walker:walk-form form))) - - -;;; - -(defslimefun getpid () - (sb-unix:unix-getpid)) ;;; Debugging Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.49 slime/swank-openmcl.lisp:1.50 --- slime/swank-openmcl.lisp:1.49 Fri Jan 16 16:49:29 2004 +++ slime/swank-openmcl.lisp Sun Jan 18 02:15:49 2004 @@ -65,9 +65,6 @@ ccl:stream-line-column ccl:stream-line-length)) -(defun without-interrupts* (body) - (ccl:without-interrupts (funcall body))) - (defvar *swank-debugger-stack-frame* nil) ;;; TCP Server @@ -92,7 +89,13 @@ (defmethod emacs-connected () (setq ccl::*interactive-abort-process* ccl::*current-process*)) -;;; +;;; Unix signals + +(defmethod call-without-interrupts (fn) + (ccl:without-interrupts (funcall fn))) + +(defmethod getpid () + (ccl::getpid)) (let ((ccl::*warn-if-redefine-kernel* nil)) (defun ccl::force-break-in-listener (p) @@ -151,16 +154,7 @@ (setq *swank-debugger-stack-frame* error-pointer)) (defmethod arglist-string (fname) - (let ((*print-case* :downcase)) - (multiple-value-bind (function condition) - (ignore-errors (values - (find-symbol-designator fname *buffer-package*))) - (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) - (let ((arglist (ccl:arglist function))) - (if arglist - (princ-to-string arglist) - "(-- )"))))) + (format-arglist fname #'ccl:arglist)) ;;; Compilation @@ -213,10 +207,6 @@ (let ((binary-filename (compile-file filename :load t))) (delete-file binary-filename))) (delete-file filename)))) - -(defslimefun getpid () - "Return the process ID of this superior Lisp." - (ccl::getpid)) ;;; Debugging Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.14 slime/swank-lispworks.lisp:1.15 --- slime/swank-lispworks.lisp:1.14 Tue Jan 13 17:51:56 2004 +++ slime/swank-lispworks.lisp Sun Jan 18 02:15:49 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.14 2004/01/13 22:51:56 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.15 2004/01/18 07:15:49 heller Exp $ ;;; (in-package :swank) @@ -27,11 +27,6 @@ stream:stream-line-column )) -(defun without-interrupts* (body) - (lispworks:without-interrupts (funcall body))) - -(defconstant +sigint+ 2) - ;;; TCP server (defun socket-fd (socket) @@ -68,29 +63,22 @@ ;; Set SIGINT handler on Swank request handler thread. (sys:set-signal-handler +sigint+ #'sigint-handler)) +;;; Unix signals + (defun sigint-handler (&rest args) (declare (ignore args)) (invoke-debugger "SIGINT")) -;;; +(defmethod call-without-interrupts (fn) + (lispworks:without-interrupts (funcall fn))) -(defslimefun getpid () - "Return the process ID of this superior Lisp." +(defmethod getpid () (system::getpid)) +;;; + (defmethod arglist-string (fname) - "Return the lambda list for function FNAME as a string." - (let ((*print-case* :downcase)) - (multiple-value-bind (function condition) - (ignore-errors (values - (find-symbol-designator fname *buffer-package*))) - (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) - (let ((arglist (and (fboundp function) - (lispworks:function-lambda-list function)))) - (if arglist - (princ-to-string arglist) - "(-- )"))))) + (format-arglist fname #'lw:function-lambda-list)) (defmethod macroexpand-all (form) (walker:walk-form form)) Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.11 slime/swank-clisp.lisp:1.12 --- slime/swank-clisp.lisp:1.11 Sun Jan 18 00:47:39 2004 +++ slime/swank-clisp.lisp Sun Jan 18 02:15:49 2004 @@ -43,18 +43,15 @@ (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil))))) #+linux -(defmacro without-interrupts (&body body) - `(with-blocked-signals (,linux:SIGINT) , at body)) +(defmethod call-without-interrupts (fn) + (with-blocked-signals (linux:SIGINT) (funcall fn))) #-linux -(defmacro without-interrupts (&body body) - `(progn , at body)) +(defmethod call-without-interrupts (fn) + (funcall fn)) -(defun without-interrupts* (fun) - (without-interrupts (funcall fun))) - -#+unix (defslimefun getpid () (system::program-id)) -#+win32 (defslimefun getpid () (or (system::getenv "PID") -1)) +#+unix (defmethod getpid () (system::program-id)) +#+win32 (defmethod getpid () (or (system::getenv "PID") -1)) ;; the above is likely broken; we need windows NT users! @@ -80,15 +77,7 @@ ;;; Swank functions (defmethod arglist-string (fname) - (declare (type string fname)) - (multiple-value-bind (function condition) - (ignore-errors (values (from-string fname))) - (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) - (multiple-value-bind (arglist condition) - (ignore-errors (values (ext:arglist function))) - (cond (condition (format nil "(-- ~A)" condition)) - (t (format nil "(~{~A~^ ~})" arglist)))))) + (format-arglist fname #'ext:arglist)) (defmethod macroexpand-all (form) (ext:expand-form form)) From heller at common-lisp.net Sun Jan 18 07:17:15 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:17:15 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20173 Modified Files: swank.lisp Log Message: (find-symbol-or-lose, format-arglist): New functions. (without-interrupts): New macro. (send-to-emacs): Use it. Date: Sun Jan 18 02:17:15 2004 Author: heller Index: slime/swank.lisp diff -u slime/swank.lisp:1.102 slime/swank.lisp:1.103 --- slime/swank.lisp:1.102 Fri Jan 16 16:49:29 2004 +++ slime/swank.lisp Sun Jan 18 02:17:15 2004 @@ -169,15 +169,18 @@ (call-with-redirected-io ,connection (lambda () , at body)) (progn , at body))) +(defmacro without-interrupts (&body body) + `(call-without-interrupts (lambda () , at body))) + ;;;; TCP Server (defvar *close-swank-socket-after-setup* nil) (defvar *use-dedicated-output-stream* t) (defvar *swank-in-background* nil) -(defun start-server (port-file &optional (background *swank-in-background*)) +(defun start-server (port-file) (setup-server 0 (lambda (port) (announce-server-port port-file port)) - background)) + *swank-in-background*)) (defun create-swank-server (&optional (port 4005) (background *swank-in-background*)) @@ -412,14 +415,13 @@ (length (1+ (length string)))) (log-event "SEND: ~A~%" string) (with-I/O-lock () - (without-interrupts* - (lambda () - (loop for position from 16 downto 0 by 8 - do (write-char (code-char (ldb (byte 8 position) length)) - output)) - (write-string string output) - (terpri output) - (force-output output)))))) + (without-interrupts + (loop for position from 16 downto 0 by 8 + do (write-char (code-char (ldb (byte 8 position) length)) + output)) + (write-string string output) + (terpri output) + (force-output output))))) (defun prin1-to-string-for-emacs (object) (with-standard-io-syntax @@ -504,6 +506,26 @@ (not (eq access :external))) (values nil nil)) (symbol (values symbol access))))))))) + +(defun find-symbol-or-lose (string &optional + (default-package *buffer-package*)) + "Like FIND-SYMBOL-DESIGNATOR but signal an error the symbols doesn't +exists." + (multiple-value-bind (symbol package) + (find-symbol-designator string default-package) + (cond (package (values symbol package)) + (t (error "Unknown symbol: ~S [in ~A]" string default-package))))) + +(defun format-arglist (function-name lambda-list-fn) + "Use LAMBDA-LIST-FN to format the arglist for FUNCTION-NAME. +Call LAMBDA-LIST-FN with the symbol corresponding to FUNCTION-NAME." + (multiple-value-bind (arglist condition) + (ignore-errors + (let ((symbol (find-symbol-or-lose function-name))) + (values (funcall lambda-list-fn symbol)))) + (cond (condition (format nil "(-- ~A)" condition)) + (t (let ((*print-case* :downcase)) + (format nil "(~{~A~^ ~})" arglist)))))) ;;;; Debugger From heller at common-lisp.net Sun Jan 18 07:19:03 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:19:03 -0500 Subject: [slime-cvs] CVS update: slime/swank-allegro.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv32320 Modified Files: swank-allegro.lisp Log Message: (arglist-string): Refactor common code to swank.lisp. (call-without-interrupts, getpid): Are now generic functions. Date: Sun Jan 18 02:19:03 2004 Author: heller Index: slime/swank-allegro.lisp diff -u slime/swank-allegro.lisp:1.8 slime/swank-allegro.lisp:1.9 --- slime/swank-allegro.lisp:1.8 Fri Jan 16 16:54:21 2004 +++ slime/swank-allegro.lisp Sun Jan 18 02:19:03 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-allegro.lisp,v 1.8 2004/01/16 21:54:21 heller Exp $ +;;; $Id: swank-allegro.lisp,v 1.9 2004/01/18 07:19:03 heller Exp $ ;;; ;;; This code was written for ;;; Allegro CL Trial Edition "5.0 [Linux/X86] (8/29/98 10:57)" @@ -32,9 +32,6 @@ excl:stream-read-char-no-hang )) -(defun without-interrupts* (body) - (excl:without-interrupts (funcall body))) - ;;;; TCP Server (defmethod create-socket (port) @@ -51,21 +48,18 @@ (defmethod emacs-connected ()) -(defslimefun getpid () +;;;; Unix signals + +(defmethod call-without-interrupts (fn) + (excl:without-interrupts (funcall fn))) + +(defmethod getpid () (excl::getpid)) ;;;; Misc (defmethod arglist-string (fname) - (declare (type string fname)) - (multiple-value-bind (function condition) - (ignore-errors (values (from-string fname))) - (when condition - (return-from arglist-string (format nil "(-- ~A)" condition))) - (multiple-value-bind (arglist condition) - (ignore-errors (values (excl:arglist function))) - (cond (condition (format nil "(-- ~A)" condition)) - (t (format nil "(~{~A~^ ~})" arglist)))))) + (format-arglist fname #'excl:arglist)) (defun apropos-symbols (string &optional external-only package) (remove-if (lambda (sym) From heller at common-lisp.net Sun Jan 18 07:21:38 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:21:38 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv9023 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Jan 18 02:21:38 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.216 slime/ChangeLog:1.217 --- slime/ChangeLog:1.216 Sun Jan 18 00:53:35 2004 +++ slime/ChangeLog Sun Jan 18 02:21:37 2004 @@ -1,3 +1,20 @@ +2004-01-18 Helmut Eller + + * swank.lisp (find-symbol-or-lose, format-arglist): New functions. + (without-interrupts): New macro. + (send-to-emacs): Use it. + + * swank-backend.lisp, swank-clisp.lisp, swank-lispworks.lisp, + swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: + (arglist-string): Refactor common code to swank.lisp. + (call-without-interrupts, getpid): Are now generic functions. + + * slime.el (arglist): Test slot readers and closures. + + * swank-cmucl.lisp (arglist-string): Use + pcl:generic-function-lambda-list for generic functions. Handle + closures. Print arglist in lower case. + 2004-01-18 Wolfgang Jenkner * swank-clisp.lisp (compile-file-for-emacs, From heller at common-lisp.net Sun Jan 18 07:39:56 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:39:56 -0500 Subject: [slime-cvs] CVS update: slime/swank-cmucl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv30585 Modified Files: swank-cmucl.lisp Log Message: (inspected-parts-of-value-cell): Was lost during the inspector refactoring. Date: Sun Jan 18 02:39:56 2004 Author: heller Index: slime/swank-cmucl.lisp diff -u slime/swank-cmucl.lisp:1.54 slime/swank-cmucl.lisp:1.55 --- slime/swank-cmucl.lisp:1.54 Sun Jan 18 02:10:21 2004 +++ slime/swank-cmucl.lisp Sun Jan 18 02:39:56 2004 @@ -1127,6 +1127,10 @@ collect (cons (format nil "~D" i) value))))) (values text parts)))))) +(defun inspected-parts-of-value-cell (o) + (values (format nil "~A~% is a value cell." o) + (list (cons "Value" (c:value-cell-ref o))))) + (defmethod inspected-parts ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) From heller at common-lisp.net Sun Jan 18 07:42:04 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:42:04 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv5794 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Jan 18 02:42:04 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.217 slime/ChangeLog:1.218 --- slime/ChangeLog:1.217 Sun Jan 18 02:21:37 2004 +++ slime/ChangeLog Sun Jan 18 02:42:04 2004 @@ -14,6 +14,8 @@ * swank-cmucl.lisp (arglist-string): Use pcl:generic-function-lambda-list for generic functions. Handle closures. Print arglist in lower case. + (inspected-parts-of-value-cell): Was lost during the inspector + refactoring. 2004-01-18 Wolfgang Jenkner From heller at common-lisp.net Sun Jan 18 07:59:00 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:59:00 -0500 Subject: [slime-cvs] CVS update: slime/swank-sbcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv16480 Modified Files: swank-sbcl.lisp Log Message: (make-fn-streams): Deleted. Already defined in swank-gray.lisp. Date: Sun Jan 18 02:59:00 2004 Author: heller Index: slime/swank-sbcl.lisp diff -u slime/swank-sbcl.lisp:1.52 slime/swank-sbcl.lisp:1.53 --- slime/swank-sbcl.lisp:1.52 Sun Jan 18 02:15:49 2004 +++ slime/swank-sbcl.lisp Sun Jan 18 02:59:00 2004 @@ -106,14 +106,6 @@ (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) -(defmethod make-fn-streams (input-fn output-fn) - (let* ((output (make-instance 'slime-output-stream - :output-fn output-fn)) - (input (make-instance 'slime-input-stream - :input-fn input-fn - :output-stream output))) - (values input output))) - (defmethod call-without-interrupts (fn) (sb-sys:without-interrupts (funcall fn))) From heller at common-lisp.net Sun Jan 18 07:59:50 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 02:59:50 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv29703 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Jan 18 02:59:49 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.218 slime/ChangeLog:1.219 --- slime/ChangeLog:1.218 Sun Jan 18 02:42:04 2004 +++ slime/ChangeLog Sun Jan 18 02:59:49 2004 @@ -1,5 +1,8 @@ 2004-01-18 Helmut Eller + * swank-sbcl.lisp (make-fn-streams): Deleted. Already defined in + swank-gray.lisp. + * swank.lisp (find-symbol-or-lose, format-arglist): New functions. (without-interrupts): New macro. (send-to-emacs): Use it. From wjenkner at common-lisp.net Sun Jan 18 15:46:08 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Sun, 18 Jan 2004 10:46:08 -0500 Subject: [slime-cvs] CVS update: slime/swank-clisp.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27200 Modified Files: swank-clisp.lisp Log Message: swank-clisp.lisp (call-without-interrupts): Evaluate linux:SIGFOO at read time since the macro with-blocked-signals expects a fixnum. (compile-file-for-emacs): Comment fix. Date: Sun Jan 18 10:46:07 2004 Author: wjenkner Index: slime/swank-clisp.lisp diff -u slime/swank-clisp.lisp:1.12 slime/swank-clisp.lisp:1.13 --- slime/swank-clisp.lisp:1.12 Sun Jan 18 02:15:49 2004 +++ slime/swank-clisp.lisp Sun Jan 18 10:46:07 2004 @@ -44,7 +44,7 @@ #+linux (defmethod call-without-interrupts (fn) - (with-blocked-signals (linux:SIGINT) (funcall fn))) + (with-blocked-signals (#.linux:SIGINT) (funcall fn))) #-linux (defmethod call-without-interrupts (fn) @@ -357,9 +357,9 @@ (signal condition)))) ;; w-p = errors + warnings, f-p = errors + warnings - style warnings, ;; where a result of 0 is replaced by NIL. It follows that w-p - ;; is T iff there was any note whatsoever and that f-p is T iff - ;; there was anything more severe than a style warning. This is - ;; completely ANSI compliant. + ;; is non-NIL iff there was any note whatsoever and that f-p is + ;; non-NIL iff there was anything more severe than a style + ;; warning. This is completely ANSI compliant. (declare (ignore w-p f-p)) (if (and fas-file load-p) (load fas-file) From wjenkner at common-lisp.net Sun Jan 18 15:49:16 2004 From: wjenkner at common-lisp.net (Wolfgang Jenkner) Date: Sun, 18 Jan 2004 10:49:16 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv14074 Modified Files: ChangeLog Log Message: Date: Sun Jan 18 10:49:16 2004 Author: wjenkner Index: slime/ChangeLog diff -u slime/ChangeLog:1.219 slime/ChangeLog:1.220 --- slime/ChangeLog:1.219 Sun Jan 18 02:59:49 2004 +++ slime/ChangeLog Sun Jan 18 10:49:16 2004 @@ -1,3 +1,10 @@ +2004-01-18 Wolfgang Jenkner + + * swank-clisp.lisp (call-without-interrupts): Evaluate + linux:SIGFOO at read time since the macro with-blocked-signals + expects a fixnum. + (compile-file-for-emacs): Comment fix. + 2004-01-18 Helmut Eller * swank-sbcl.lisp (make-fn-streams): Deleted. Already defined in From aruttenberg at common-lisp.net Sun Jan 18 16:17:37 2004 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 18 Jan 2004 11:17:37 -0500 Subject: [slime-cvs] CVS update: slime/swank-openmcl.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv23272/slime Modified Files: swank-openmcl.lisp Log Message: Implement frame-catch-tags. Added debugger functions sldb-restart-frame, sldb-return-from-frame. Should probably be added to backend.lisp but let's discuss first. Do other lisps support this? Date: Sun Jan 18 11:17:37 2004 Author: aruttenberg Index: slime/swank-openmcl.lisp diff -u slime/swank-openmcl.lisp:1.50 slime/swank-openmcl.lisp:1.51 --- slime/swank-openmcl.lisp:1.50 Sun Jan 18 02:15:49 2004 +++ slime/swank-openmcl.lisp Sun Jan 18 11:17:37 2004 @@ -330,9 +330,27 @@ result)))) (return-from frame-locals (nreverse result)))))))) -(defmethod frame-catch-tags (index) - (declare (ignore index)) - nil) +(defmethod frame-catch-tags (index &aux my-frame) + (map-backtrace + (lambda (frame-number p tcr lfun pc) + (declare (ignore pc lfun)) + (if (= frame-number index) + (setq my-frame p) + (when my-frame + (return-from frame-catch-tags + (loop for catch = (ccl::%catch-top tcr) then (ccl::next-catch catch) + while catch + for csp = (ccl::uvref catch ppc32::catch-frame.csp-cell) + for tag = (ccl::uvref catch ppc32::catch-frame.catch-tag-cell) + until (ccl::%stack< p csp tcr) + do (print "-") (print catch) (terpri) (describe tag) + when (ccl::%stack< my-frame csp tcr) + collect (cond + ((symbolp tag) + (list tag)) + ((and (listp tag) + (typep (car tag) 'restart) + (list `(:restart ,(restart-name (car tag)))))))))))))) (defslimefun sldb-disassemble (the-frame-number) "Return a string with the disassembly of frames code." @@ -447,6 +465,20 @@ ,@(mapcar 'car bindings))) ,form))) )))))) + +(defslimefun sldb-return-from-frame (form index) + (let ((values (multiple-value-list (eval-in-frame (from-string form) index)))) + (map-backtrace + (lambda (frame-number p tcr lfun pc) + (declare (ignore tcr lfun pc)) + (when (= frame-number index) + (ccl::apply-in-frame p #'values values)))))) + +(defslimefun sldb-restart-frame (index) + (map-backtrace + (lambda (frame-number p tcr lfun pc) + (when (= frame-number index) + (ccl::apply-in-frame p lfun (ccl::frame-supplied-args p lfun pc nil tcr)))))) ;;; Utilities From aruttenberg at common-lisp.net Sun Jan 18 16:18:41 2004 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 18 Jan 2004 11:18:41 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv26340/slime Modified Files: slime.el Log Message: sldb-restart-frame, sldb-return-from-frame Date: Sun Jan 18 11:18:40 2004 Author: aruttenberg Index: slime/slime.el diff -u slime/slime.el:1.184 slime/slime.el:1.185 --- slime/slime.el:1.184 Sun Jan 18 02:11:39 2004 +++ slime/slime.el Sun Jan 18 11:18:35 2004 @@ -4355,6 +4355,18 @@ (interactive) (let ((frame (sldb-frame-number-at-point))) (slime-eval-async `(swank:sldb-step ,frame) nil (lambda ())))) + +(defun sldb-return-from-frame (string) + "reads an expression in the minibuffer and causes the function to return that value, evaluated in the context of the frame" + (interactive (list (slime-read-from-minibuffer "Return from frame: "))) + (let* ((number (sldb-frame-number-at-point))) + (slime-oneway-eval `(swank::sldb-return-from-frame ,string ,number) (slime-buffer-package)))) +(defun sldb-restart-frame () + "causes the frame to restart execution with the same arguments as it was called originally" + (interactive) + (let* ((number (sldb-frame-number-at-point))) + (slime-oneway-eval `(swank::sldb-restart-frame ,number) (slime-buffer-package)))) + ;;; Thread control panel From aruttenberg at common-lisp.net Sun Jan 18 16:19:09 2004 From: aruttenberg at common-lisp.net (Alan Ruttenberg) Date: Sun, 18 Jan 2004 11:19:09 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv28386/slime Modified Files: ChangeLog Log Message: Date: Sun Jan 18 11:19:09 2004 Author: aruttenberg Index: slime/ChangeLog diff -u slime/ChangeLog:1.220 slime/ChangeLog:1.221 --- slime/ChangeLog:1.220 Sun Jan 18 10:49:16 2004 +++ slime/ChangeLog Sun Jan 18 11:19:09 2004 @@ -1,3 +1,11 @@ +2004-01-18 Alan Ruttenberg + + * swank-openmcl: Implement frame-catch-tags. Added debugger functions + sldb-restart-frame, sldb-return-from-frame. Should probably be added to backend.lisp + but let's discuss first. Do other lisps support this? + + * slime.el sldb-restart-frame, sldb-return-from-frame + 2004-01-18 Wolfgang Jenkner * swank-clisp.lisp (call-without-interrupts): Evaluate From heller at common-lisp.net Sun Jan 18 20:01:44 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 15:01:44 -0500 Subject: [slime-cvs] CVS update: slime/swank-lispworks.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv8832 Modified Files: swank-lispworks.lisp Log Message: (sigint-handler): Bind a continue restart. (make-dspec-location): Handle stings like pathnames. Some multithreading support. Date: Sun Jan 18 15:01:44 2004 Author: heller Index: slime/swank-lispworks.lisp diff -u slime/swank-lispworks.lisp:1.15 slime/swank-lispworks.lisp:1.16 --- slime/swank-lispworks.lisp:1.15 Sun Jan 18 02:15:49 2004 +++ slime/swank-lispworks.lisp Sun Jan 18 15:01:44 2004 @@ -7,7 +7,7 @@ ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; -;;; $Id: swank-lispworks.lisp,v 1.15 2004/01/18 07:15:49 heller Exp $ +;;; $Id: swank-lispworks.lisp,v 1.16 2004/01/18 20:01:44 heller Exp $ ;;; (in-package :swank) @@ -67,7 +67,8 @@ (defun sigint-handler (&rest args) (declare (ignore args)) - (invoke-debugger "SIGINT")) + (with-simple-restart (continue "Continue from SIGINT handler.") + (invoke-debugger "SIGINT"))) (defmethod call-without-interrupts (fn) (lispworks:without-interrupts (funcall fn))) @@ -304,7 +305,7 @@ (make-location `(:buffer ,buffer) `(:position ,position))) (t (etypecase location - (pathname + ((or pathname string) (make-location `(:file ,(filename location)) `(:function-name ,(function-name dspec)))) ((member :listener) @@ -378,9 +379,24 @@ (defslimefun list-callees (symbol-name) (lookup-xrefs #'hcl:calls-who symbol-name)) -;; (dspec:at-location -;; ('(:inside (:buffer "foo" 34))) -;; (defun foofun () (foofun))) +;;; Multithreading + +(defmethod startup-multiprocessing () + (mp:initialize-multiprocessing)) + +(defmethod spawn (fn &key name) + (mp:process-run-function name () fn)) + +;; XXX: shurtcut +(defmethod thread-id () + (mp:process-name mp:*current-process*)) + +(defmethod thread-name (thread-id) + thread-id) + +(defmethod make-lock (&key name) + (mp:make-lock :name name)) + +(defmethod call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) -;; (dspec:find-dspec-locations 'xref-results-for-emacs) -;; (who-binds '*package*) \ No newline at end of file From heller at common-lisp.net Sun Jan 18 20:04:21 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 15:04:21 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv27233 Modified Files: slime.el Log Message: (compile-defun): Don't use keywords. The keyword package is locked in Lispworks and causes the test-suite to hang. Date: Sun Jan 18 15:04:20 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.185 slime/slime.el:1.186 --- slime/slime.el:1.185 Sun Jan 18 11:18:35 2004 +++ slime/slime.el Sun Jan 18 15:04:20 2004 @@ -4914,20 +4914,21 @@ (program subform) "Compile PROGRAM containing errors. Confirm that SUBFORM is correctly located." - '(("(defun :foo () (:bar))" (:bar)) - ("(defun :foo () + '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) + ("(defun cl-user::foo () #\\space ;;Sdf - (:bar))" - (:bar)) - ("(defun :foo () + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () #+(or)skipped #| #||# #||# |# - (:bar))" - (:bar)) - ("(defun :foo () (list `(1 ,(random 10) 2 ,@(random 10) 3 ,(:bar))))" - (:bar)) + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + (list `(1 ,(random 10) 2 ,@(random 10) 3 ,(cl-user::bar))))" + (cl-user::bar)) ) (with-temp-buffer (lisp-mode) From heller at common-lisp.net Sun Jan 18 20:06:05 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 15:06:05 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv3615 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Jan 18 15:06:05 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.221 slime/ChangeLog:1.222 --- slime/ChangeLog:1.221 Sun Jan 18 11:19:09 2004 +++ slime/ChangeLog Sun Jan 18 15:06:04 2004 @@ -1,3 +1,12 @@ +2004-01-18 Helmut Eller + + * swank-lispworks.lisp (sigint-handler): Bind a continue restart. + (make-dspec-location): Handle stings like pathnames. + Some multithreading support. + + * slime.el (compile-defun): Don't use keywords. The keyword + package is locked in Lispworks and causes the test-suite to hang. + 2004-01-18 Alan Ruttenberg * swank-openmcl: Implement frame-catch-tags. Added debugger functions From heller at common-lisp.net Sun Jan 18 21:53:00 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 16:53:00 -0500 Subject: [slime-cvs] CVS update: slime/slime.el Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv15105 Modified Files: slime.el Log Message: (slime-eval-with-transcript): Fix bug triggered when 'package' is a buffer local variable. Reported by Janis Dzerins. (slime-batch-test): Wait until the connection is ready. Date: Sun Jan 18 16:52:59 2004 Author: heller Index: slime/slime.el diff -u slime/slime.el:1.186 slime/slime.el:1.187 --- slime/slime.el:1.186 Sun Jan 18 15:04:20 2004 +++ slime/slime.el Sun Jan 18 16:52:59 2004 @@ -3275,15 +3275,14 @@ (defun slime-eval-with-transcript (form package &optional fn) (with-current-buffer (slime-output-buffer) - (slime-with-output-end-mark - (slime-mark-output-start)) - (with-lexical-bindings (fn) - (slime-eval-async form package - (lambda (value) - (with-current-buffer (slime-output-buffer) - (cond (fn (funcall fn value)) - (t (message "=> %s" value))) - (slime-show-last-output))))))) + (slime-with-output-end-mark (slime-mark-output-start))) + (with-lexical-bindings (fn) + (slime-eval-async form package + (lambda (value) + (with-current-buffer (slime-output-buffer) + (cond (fn (funcall fn value)) + (t (message "=> %s" value))) + (slime-show-last-output)))))) (defun slime-eval-describe (form) (lexical-let ((package (slime-buffer-package))) @@ -4715,6 +4714,8 @@ (slime-test-debug-on-error nil)) (slime) ;; Block until we are up and running. + (while (not (slime-connected-p)) + (accept-process-output nil 2)) (slime-sync-state-stack '(slime-idle-state) 120) (switch-to-buffer "*scratch*") (let ((failed-tests (slime-run-tests))) From heller at common-lisp.net Sun Jan 18 21:54:07 2004 From: heller at common-lisp.net (Helmut Eller) Date: Sun, 18 Jan 2004 16:54:07 -0500 Subject: [slime-cvs] CVS update: slime/ChangeLog Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17546 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Jan 18 16:54:06 2004 Author: heller Index: slime/ChangeLog diff -u slime/ChangeLog:1.222 slime/ChangeLog:1.223 --- slime/ChangeLog:1.222 Sun Jan 18 15:06:04 2004 +++ slime/ChangeLog Sun Jan 18 16:54:06 2004 @@ -1,11 +1,14 @@ 2004-01-18 Helmut Eller * swank-lispworks.lisp (sigint-handler): Bind a continue restart. - (make-dspec-location): Handle stings like pathnames. + (make-dspec-location): Handle strings like pathnames. Some multithreading support. * slime.el (compile-defun): Don't use keywords. The keyword package is locked in Lispworks and causes the test-suite to hang. + (slime-eval-with-transcript): Fix bug triggered when 'package' is + a buffer local variable. Reported by Janis Dzerins. + (slime-batch-test): Wait until the connection is ready. 2004-01-18 Alan Ruttenberg From 27wezfdsd at netzero.com Sun Jan 18 20:53:07 2004 From: 27wezfdsd at netzero.com (Casandra Snyder) Date: Sun, 18 Jan 04 20:53:07 GMT Subject: [slime-cvs] Re: did I send this to you? Message-ID: An HTML attachment was scrubbed... URL: From lgorrie at common-lisp.net Mon Jan 19 20:12:29 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 19 Jan 2004 15:12:29 -0500 Subject: [slime-cvs] CVS update: slime/swank.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv17760 Modified Files: swank.lisp Log Message: (ed-in-emacs): New command with the same interface as CL:ED. Date: Mon Jan 19 15:12:29 2004 Author: lgorrie Index: slime/swank.lisp diff -u slime/swank.lisp:1.103 slime/swank.lisp:1.104 --- slime/swank.lisp:1.103 Sun Jan 18 02:17:15 2004 +++ slime/swank.lisp Mon Jan 19 15:12:28 2004 @@ -423,6 +423,9 @@ (terpri output) (force-output output))))) +(defun send-oob-to-emacs (object) + (send-to-emacs object (connection.socket-io *main-connection*))) + (defun prin1-to-string-for-emacs (object) (with-standard-io-syntax (let ((*print-case* :downcase) @@ -764,6 +767,13 @@ (let ((*package* *buffer-package*)) (format nil "~{~S~^~%~}" values)))))) +(defslimefun ed-in-emacs (&optional what) + "Edit WHAT in Emacs. +WHAT can be a filename (pathname or string) or function name (symbol)." + (send-oob-to-emacs `(:ed ,(if (pathnamep what) + (canonicalize-filename what) + what)))) + ;;;; Compilation Commands. @@ -825,7 +835,6 @@ Record compiler notes signalled as `compiler-condition's." (swank-compiler (lambda () (compile-system-for-emacs system)))) - ;;;; Macroexpansion @@ -997,7 +1006,12 @@ "Make an apropos search for Emacs. The result is a list of property lists." (mapcan (listify #'briefly-describe-symbol-for-emacs) - (sort (apropos-symbols name external-only package) + (sort (apropos-symbols name + external-only + (if package + (or (find-package (read-from-string package)) + (error "No such package: ~S" package)) + nil)) #'present-symbol-before-p))) (defun briefly-describe-symbol-for-emacs (symbol) @@ -1044,7 +1058,7 @@ (remove-if (lambda (sym) (or (keywordp sym) (and external-only - (not (equal (symbol-package sym) *buffer-package*)) +;; (not (equal (symbol-package sym) *buffer-package*)) (not (symbol-external-p sym))))) (apropos-list string package))) From lgorrie at common-lisp.net Mon Jan 19 20:13:23 2004 From: lgorrie at common-lisp.net (Luke Gorrie) Date: Mon, 19 Jan 2004 15:13:23 -0500 Subject: [slime-cvs] CVS update: slime/swank-backend.lisp Message-ID: Update of /project/slime/cvsroot/slime In directory common-lisp.net:/tmp/cvs-serv20705 Modified Files: swank-backend.lisp Log Message: (definterface, defimplementation): New macros as sugar around defgeneric/defmethod. This supports conveniently supplying a default (on NO-APPLICABLE-METHOD). Because the underly mechanism is still generic functions this doesn't break code that isn't updated. (warn-unimplemented-interfaces): Print a list of backend functions that are not implemented. (xref and list-callers): Defined interfaces for these functions. (describe-definition): New function that takes over from the many other describe-* functions called from apropos listing. Takes the type of definition (as returned by describe-symbol-for-emacs) as an argument. Date: Mon Jan 19 15:13:23 2004 Author: lgorrie Index: slime/swank-backend.lisp diff -u slime/swank-backend.lisp:1.20 slime/swank-backend.lisp:1.21 --- slime/swank-backend.lisp:1.20 Sun Jan 18 02:15:49 2004 +++ slime/swank-backend.lisp Mon Jan 19 15:13:23 2004 @@ -21,16 +21,9 @@ #:completions #:create-server #:create-swank-server - #:describe-alien-enum - #:describe-alien-struct - #:describe-alien-type - #:describe-alien-union - #:describe-class - #:describe-function - #:describe-inspectee - #:describe-setf-function + #:describe-definition #:describe-symbol - #:describe-type + #:describe-symbol-for-emacs #:disassemble-symbol #:documentation-symbol #:eval-in-frame @@ -83,6 +76,7 @@ #:toggle-trace-fdefinition #:untrace-all #:wait-goahead + #:warn-unimplemented-interfaces #:who-binds #:who-calls #:who-macroexpands @@ -93,43 +87,84 @@ (in-package :swank) +;;;; Metacode + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defmacro definterface (name args documentation &body default-body) + "Define an interface function for the backend to implement. +A generic function is defined with NAME, ARGS, and DOCUMENTATION. + +If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized +to execute the body if the backend doesn't provide a specific +implementation. + +Backends implement these functions using DEFIMPLEMENTATION." + (flet ((gen-default-impl () + (let ((received-args (gensym "ARGS-"))) + `(defmethod no-applicable-method ((#:method + (eql (function ,name))) + &rest ,received-args) + (destructuring-bind ,args ,received-args + , at default-body))))) + `(prog1 (defgeneric ,name ,args (:documentation ,documentation)) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl))))) + +(defmacro defimplementation (name args &body body) + ;; Is this a macro no-no -- should it be pushed out of macroexpansion? + `(prog1 (defmethod ,name ,args , at body) + (if (member ',name *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',name *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (S)" ',name)))) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (warn "These Swank interfaces are unimplemented:~% ~A" + (sort (copy-list *unimplemented-interfaces*) #'string<))) + + ;;;; TCP server -(defgeneric create-socket (port) - (:documentation "Create a listening TCP socket on port PORT.")) +(definterface create-socket (port) + "Create a listening TCP socket on port PORT.") -(defgeneric local-port (socket) - (:documentation "Return the local port number of SOCKET.")) +(definterface local-port (socket) + "Return the local port number of SOCKET.") -(defgeneric close-socket (socket) - (:documentation "Close the socket SOCKET.")) +(definterface close-socket (socket) + "Close the socket SOCKET.") -(defgeneric accept-connection (socket) - (:documentation +(definterface accept-connection (socket) "Accept a client connection on the listening socket SOCKET. Return -a stream for the new connection.")) +a stream for the new connection.") -(defgeneric add-input-handler (socket fn) - (:documentation "Call FN whenever SOCKET is readable.")) +(definterface add-input-handler (socket fn) + "Call FN whenever SOCKET is readable.") -(defgeneric remove-input-handlers (socket) - (:documentation "Remove all input handlers for SOCKET.")) +(definterface remove-input-handlers (socket) + "Remove all input handlers for SOCKET.") ;;; Base condition for networking errors. (define-condition network-error (error) ()) -(defgeneric emacs-connected () - (:documentation +(definterface emacs-connected () "Hook called when the first connection from Emacs is established. Called from the INIT-FN of the socket server that accepts the connection. This is intended for setting up extra context, e.g. to discover -that the calling thread is the one that interacts with Emacs.")) - -(defmethod no-applicable-method ((m (eql #'emacs-connected)) &rest _) - (declare (ignore _)) - nil) +that the calling thread is the one that interacts with Emacs." + nil) ;;;; Unix signals @@ -145,28 +180,25 @@ ;;;; Compilation -(defgeneric call-with-compilation-hooks (func) - (:documentation - "Call FUNC with hooks to trigger SLDB on compiler errors.")) +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to trigger SLDB on compiler errors.") (defmacro with-compilation-hooks ((&rest ignore) &body body) (declare (ignore ignore)) `(call-with-compilation-hooks (lambda () (progn , at body)))) -(defgeneric compile-string-for-emacs (string &key buffer position) - (:documentation +(definterface compile-string-for-emacs (string &key buffer position) "Compile source from STRING. During compilation, compiler conditions must be trapped and resignalled as COMPILER-CONDITIONs. If supplied, BUFFER and POSITION specify the source location in Emacs. Additionally, if POSITION is supplied, it must be added to source -positions reported in compiler conditions.")) +positions reported in compiler conditions.") -(defgeneric compile-file-for-emacs (filename load-p) - (:documentation +(definterface compile-file-for-emacs (filename load-p) "Compile FILENAME signalling COMPILE-CONDITIONs. -If LOAD-P is true, load the file after compilation.")) +If LOAD-P is true, load the file after compilation.") (deftype severity () '(member :error :warning :style-warning :note)) @@ -192,8 +224,7 @@ ;;;; Streams -(defgeneric make-fn-streams (input-fn output-fn) - (:documentation +(definterface make-fn-streams (input-fn output-fn) "Return character input and output streams backended by functions. When input is needed, INPUT-FN is called with no arguments to return a string. @@ -202,23 +233,20 @@ Output should be forced to OUTPUT-FN before calling INPUT-FN. -The streams are returned as two values.")) +The streams are returned as two values.") ;;;; Documentation -(defgeneric arglist-string (function-name) - (:documentation +(definterface arglist-string (function-name) "Return the argument for FUNCTION-NAME as a string. -The result should begin and end with parenthesis.")) +The result should begin and end with parenthesis.") -(defgeneric macroexpand-all (form) - (:documentation +(definterface macroexpand-all (form) "Recursively expand all macros in FORM. -Return the resulting form.")) +Return the resulting form.") -(defgeneric describe-symbol-for-emacs (symbol) - (:documentation +(definterface describe-symbol-for-emacs (symbol) "Return a property list describing SYMBOL. The property list has an entry for each interesting aspect of the @@ -238,13 +266,18 @@ \(describe-symbol-for-emacs 'vector) => (:CLASS :NOT-DOCUMENTED :TYPE :NOT-DOCUMENTED - :FUNCTION \"Constructs a simple-vector from the given objects.\")")) + :FUNCTION \"Constructs a simple-vector from the given objects.\")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") ;;;; Debugging -(defgeneric call-with-debugging-environment (debugger-loop-fn) - (:documentation +(definterface call-with-debugging-environment (debugger-loop-fn) "Call DEBUGGER-LOOP-FN in a suitable debugging environment. This function is called recursively at each debug level to invoke the @@ -252,7 +285,7 @@ other debugger callbacks that will be called within the debugger loop. For example, this is a reasonable place to compute a backtrace, switch -to safe reader/printer settings, and so on.")) +to safe reader/printer settings, and so on.") (define-condition sldb-condition (condition) ((original-condition @@ -267,8 +300,7 @@ user without (re)entering the debugger by wrapping them as `sldb-condition's.")) -(defgeneric debugger-info-for-emacs (start end) - (:documentation +(definterface debugger-info-for-emacs (start end) "Return debugger state, with stack frames from START to END. The result is a list: (condition ({restart}*) ({stack-frame}*) @@ -293,10 +325,9 @@ \"[Condition of type DIVISION-BY-ZERO]\") ((\"ABORT\" \"Return to Slime toplevel.\") (\"ABORT\" \"Return to Top-Level.\")) - ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))") -(defgeneric backtrace (start end) - (:documentation +(definterface backtrace (start end) "Return a list containing a backtrace of the condition current being debugged. The results are unspecified if this function is called outside the dynamic contour of a debugger hook defined by @@ -316,28 +347,24 @@ ((0 \"(HELLO \"world\")\") (1 \"(RUN-EXCITING-LISP-DEMO)\") - (2 \"(SYS::%TOPLEVEL #)\"))")) + (2 \"(SYS::%TOPLEVEL #)\"))") -(defgeneric frame-source-location-for-emacs (frame-number) - (:documentation - "Return the source location for FRAME-NUMBER.")) +(definterface frame-source-location-for-emacs (frame-number) + "Return the source location for FRAME-NUMBER.") -(defgeneric frame-catch-tags (frame-number) - (:documentation +(definterface frame-catch-tags (frame-number) "Return a list of XXX list of what? catch tags for a debugger stack frame. The results are undefined unless this is called within the dynamic contour of a function defined by -DEFINE-DEBUGGER-HOOK.")) +DEFINE-DEBUGGER-HOOK.") -(defgeneric frame-locals (frame-number) - (:documentation +(definterface frame-locals (frame-number) "Return a list of XXX local variable designators define me for a debugger stack frame. The results are undefined unless this is called within the dynamic contour of a function defined -by DEFINE-DEBUGGER-HOOK.")) +by DEFINE-DEBUGGER-HOOK.") -(defgeneric eval-in-frame (form frame-number) - (:documentation +(definterface eval-in-frame (form frame-number) "Evaluate a Lisp form in the lexical context of a stack frame in the debugger. The results are undefined unless called in the dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK. @@ -346,15 +373,14 @@ frame which invoked the debugger. The return value is the result of evaulating FORM in the -appropriate context.")) +appropriate context.") ;;;; Queries #+(or) ;;; This is probably a better interface than find-function-locations. -(defgeneric find-definitions (name) - (:documentation +(definterface find-definitions (name) "Return a list of (LABEL . LOCATION) pairs for NAME's definitions. NAME is string denoting a symbol or \"definition specifier\". @@ -373,10 +399,9 @@ ::= (:position []) ; 1 based | (:function-name ) -")) +") -(defgeneric find-function-locations (name) - (:documentation +(definterface find-function-locations (name) "Return a list (LOCATION LOCATION ...) for NAME's definitions. LOCATION is a source location of the form: @@ -392,7 +417,7 @@ | (:line []) | (:function-name ) | (:source-path ) -")) +") ;;;; Inspector @@ -407,21 +432,23 @@ ;;;; Multiprocessing +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. -(defgeneric startup-multiprocessing () - (:documentation +(definterface startup-multiprocessing () "Initialize multiprocessing, if necessary. This function is called directly through the listener, not in an RPC from Emacs. This is to support interfaces such as CMUCL's MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a -normal function.")) +normal function." + nil) -(defgeneric spawn (fn &key name) - (:documentation "Create a new thread to call FN.")) +(definterface spawn (fn &key name) + "Create a new thread to call FN.") -(defgeneric thread-id () - (:documentation +(definterface thread-id () "Return a value that uniquely identifies the current thread. Thread-IDs allow Emacs to refer to individual threads. @@ -432,43 +459,71 @@ For example, a THREAD-ID could be an integer or a short ASCII string. -Systems that do not support multiprocessing return NIL.")) +Systems that do not support multiprocessing return NIL." + nil) -(defgeneric thread-name (thread-id) - (:documentation +(definterface thread-name (thread-id) "Return the name of the thread identified by THREAD-ID. Thread names are be single-line strings and are meaningful to the -user. They do not have to be unique.")) +user. They do not have to be unique." + (declare (ignore thread-id)) + "The One True Thread") -(defgeneric make-lock (&key name) - (:documentation +(definterface make-lock (&key name) "Make a lock for thread synchronization. -Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time.")) +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time." + :null-lock) -(defgeneric call-with-lock-held (lock function) - (:documentation - "Call FUNCTION with LOCK held, queueing if necessary.")) +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock)) + (funcall function)) -;;;;; Default implementation for non-MP systems +;;;; XREF -;;; Using NO-APPLICABLE-METHOD to supply a default implementation that -;;; works in systems that don't have multiprocessing. -;;; (Good or bad idea? -luke) - -(defmethod no-applicable-method ((m (eql #'startup-multiprocessing)) &rest _) - (declare (ignore _)) - nil) -(defmethod no-applicable-method ((m (eql #'thread-id)) &rest _) - (declare (ignore _)) - nil) -(defmethod no-applicable-method ((m (eql #'thread-name)) &rest _) - (declare (ignore _)) - "The One True Thread") -(defmethod no-applicable-method ((m (eql #'make-lock)) &rest _) - (declare (ignore _)) - :null-lock) -(defmethod no-applicable-method ((m (eql #'call-with-lock-held)) &rest args) - (funcall (second args))) +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a string). +The results are grouped together by filename: + ::= (*) + ::= ( . (*)) + ::= (