Author: ksprotte
Date: Fri Jan 18 12:41:19 2008
New Revision: 2359
Modified:
branches/bos/projects/bos/m2/allocation-cache.lisp
Log:
allocation-cache uses now ensure-m2 instead of get-m2
to retrieve a m2 instance for a point that is inside
the polygon
Modified: branches/bos/projects/bos/m2/allocation-cache.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-cache.lisp (original)
+++ branches/bos/projects/bos/m2/allocation-cache.lisp Fri Jan 18 12:41:19 2008
@@ -29,7 +29,7 @@
(loop for y from top upto (1- (+ top height))
do (loop for x from left upto (1- (+ left width))
for spot = (when (point-in-polygon-p x y vertices)
- (get-m2 x y))
+ (ensure-m2 x y))
for x0 = (- x left)
for y0 = (- y top)
do (setf (aref array x0 y0) spot)))
1
0
18 Jan '08
Author: hhubner
Date: Fri Jan 18 11:50:57 2008
New Revision: 2358
Modified:
branches/bos/projects/bos/Makefile
branches/bos/projects/bos/build.lisp
branches/bos/projects/bos/m2/config.lisp
branches/bos/projects/bos/m2/m2.lisp
branches/bos/projects/bos/m2/mail-generator.lisp
Log:
suppress mail sending unless expressly enabled.
Modified: branches/bos/projects/bos/Makefile
==============================================================================
--- branches/bos/projects/bos/Makefile (original)
+++ branches/bos/projects/bos/Makefile Fri Jan 18 11:50:57 2008
@@ -16,7 +16,7 @@
.PHONY: test
test: bos.core
- lisp -core bos.core -test -slime
+ lisp -core bos.core -run-tests -slime
# various cleaning stuff
.PHONY: cleancore
Modified: branches/bos/projects/bos/build.lisp
==============================================================================
--- branches/bos/projects/bos/build.lisp (original)
+++ branches/bos/projects/bos/build.lisp Fri Jan 18 11:50:57 2008
@@ -29,7 +29,7 @@
(define-toggle-switch "nostart" *webserver* t)
(define-toggle-switch "slime" *slime* nil)
(define-toggle-switch "cert-daemon" *cert-daemon* nil)
-(define-toggle-switch "test" *run-tests* nil)
+(define-toggle-switch "run-tests" *run-tests* nil)
(defun start-webserver ()
(apply #'bos.m2::reinit (read-configuration "m2.rc"))
@@ -61,7 +61,7 @@
(format t "BOS Online-System~%")
(when *run-tests*
(asdf:oos 'asdf:load-op :bos.test)
- (format t "Starting BOS tests...~%")
+ (format t "Starting BOS tests...~%")
(eval (read-from-string "(5am:run! :bos.test)"))
(terpri)
(finish-output)
@@ -73,13 +73,9 @@
(start-slime))
(when *webserver*
(start-webserver))
- (cond
- (*run-tests*
- (asdf:oos 'asdf:load-op :bos.test)
- (eval (read-from-string "(5am:run! :bos.test)")))
- (t (when (or *slime* *webserver*)
- (mp::startup-idle-and-top-level-loops))
- (lisp::%top-level))))
+ (when (or *slime* *webserver*)
+ (mp::startup-idle-and-top-level-loops))
+ (lisp::%top-level))
(setf *default-pathname-defaults* #p"")
(when (probe-file "bos.core")
Modified: branches/bos/projects/bos/m2/config.lisp
==============================================================================
--- branches/bos/projects/bos/m2/config.lisp (original)
+++ branches/bos/projects/bos/m2/config.lisp Fri Jan 18 11:50:57 2008
@@ -68,4 +68,7 @@
(defparameter *manual-contract-expiry-time* (* 42 24 3600))
(defparameter *online-contract-expiry-time* (* 3600))
-(defvar *website-url* "http://change-me")
\ No newline at end of file
+(defvar *website-url* "http://change-me")
+
+;; Einschalten des Mail-Versands (normalerweise aus)
+(defvar *enable-mails* nil)
\ No newline at end of file
Modified: branches/bos/projects/bos/m2/m2.lisp
==============================================================================
--- branches/bos/projects/bos/m2/m2.lisp (original)
+++ branches/bos/projects/bos/m2/m2.lisp Fri Jan 18 11:50:57 2008
@@ -445,9 +445,10 @@
#-(or allegro cmu sbcl)
...))
-(defun reinit (&key delete directory website-url)
+(defun reinit (&key delete directory website-url enable-mails)
(format t "~&; Startup Quadratmeterdatenbank...~%")
(force-output)
+ (setf *enable-mails* enable-mails)
(setf *website-url* website-url)
(unless directory
(error ":DIRECTORY parameter not set in m2.rc"))
Modified: branches/bos/projects/bos/m2/mail-generator.lisp
==============================================================================
--- branches/bos/projects/bos/m2/mail-generator.lisp (original)
+++ branches/bos/projects/bos/m2/mail-generator.lisp Fri Jan 18 11:50:57 2008
@@ -14,21 +14,23 @@
(country->office-email (sponsor-country (contract-sponsor contract))))
(defun send-system-mail (&key (to *office-mail-address*) (subject "(no subject") (text "(no text)") (content-type "text/plain; charset=UTF-8") more-headers)
- (send-smtp "localhost" *mail-sender* to
- (format nil "X-Mailer: BKNR-BOS-mailer
+ (if *enable-mails*
+ (send-smtp "localhost" *mail-sender* to
+ (format nil "X-Mailer: BKNR-BOS-mailer
Date: ~A
From: ~A
To: ~A
Subject: ~A
~@[Content-Type: ~A
~]~@[~*~%~]~A"
- (format-date-time (get-universal-time) :mail-style t)
- *mail-sender*
- to
- subject
- content-type
- (not more-headers)
- text)))
+ (format-date-time (get-universal-time) :mail-style t)
+ *mail-sender*
+ to
+ subject
+ content-type
+ (not more-headers)
+ text))
+ (format t "Mail with subject ~S to ~A not sent~%" subject to)))
(defun mail-info-request (email country)
(send-system-mail :subject "Mailing list request"
1
0
18 Jan '08
Author: ksprotte
Date: Fri Jan 18 11:44:59 2008
New Revision: 2357
Modified:
branches/bos/projects/bos/m2/allocation-cache.lisp
branches/bos/projects/bos/m2/bos.m2.asd
branches/bos/projects/bos/m2/m2.lisp
branches/bos/projects/bos/m2/packages.lisp
branches/bos/projects/bos/test/allocation-area.lisp
branches/bos/projects/bos/test/fixtures.lisp
Log:
added allocation-cache-subsystem
Modified: branches/bos/projects/bos/m2/allocation-cache.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-cache.lisp (original)
+++ branches/bos/projects/bos/m2/allocation-cache.lisp Fri Jan 18 11:44:59 2008
@@ -183,3 +183,11 @@
(unless (zerop region-count)
(leave size))))
+;;; subsystem
+(defclass allocation-cache-subsystem ()
+ ())
+
+(defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem) &key until)
+ (declare (ignore until))
+ (rebuild-cache))
+
Modified: branches/bos/projects/bos/m2/bos.m2.asd
==============================================================================
--- branches/bos/projects/bos/m2/bos.m2.asd (original)
+++ branches/bos/projects/bos/m2/bos.m2.asd Fri Jan 18 11:44:59 2008
@@ -1,21 +1,21 @@
(in-package :cl-user)
(asdf:defsystem :bos.m2
- :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate)
- :components ((:file "packages")
- (:file "config" :depends-on ("packages"))
- (:file "utils" :depends-on ("config"))
- (:file "news" :depends-on ("poi"))
- (:file "tiled-index" :depends-on ("config"))
- (:file "mail-generator" :depends-on ("config"))
- (:file "make-certificate" :depends-on ("config"))
- (:file "m2" :depends-on ("tiled-index" "utils" "make-certificate" "mail-generator"))
- (:file "contract-expiry" :depends-on ("m2"))
- (:file "allocation" :depends-on ("m2"))
- (:file "allocation-cache" :depends-on ("packages"))
- (:file "poi" :depends-on ("utils" "allocation"))
- (:file "bitmap" :depends-on ("allocation"))
- (:file "import" :depends-on ("m2"))
- (:file "map" :depends-on ("m2" "allocation"))
- (:file "export" :depends-on ("m2"))
- (:file "cert-daemon" :depends-on ("config"))))
+ :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate)
+ :components ((:file "packages")
+ (:file "config" :depends-on ("packages"))
+ (:file "utils" :depends-on ("config"))
+ (:file "news" :depends-on ("poi"))
+ (:file "tiled-index" :depends-on ("config"))
+ (:file "mail-generator" :depends-on ("config"))
+ (:file "make-certificate" :depends-on ("config"))
+ (:file "m2" :depends-on ("tiled-index" "utils" "make-certificate" "mail-generator"))
+ (:file "contract-expiry" :depends-on ("m2"))
+ (:file "allocation" :depends-on ("m2"))
+ (:file "allocation-cache" :depends-on ("packages"))
+ (:file "poi" :depends-on ("utils" "allocation"))
+ (:file "bitmap" :depends-on ("allocation"))
+ (:file "import" :depends-on ("m2"))
+ (:file "map" :depends-on ("m2" "allocation"))
+ (:file "export" :depends-on ("m2"))
+ (:file "cert-daemon" :depends-on ("config"))))
Modified: branches/bos/projects/bos/m2/m2.lisp
==============================================================================
--- branches/bos/projects/bos/m2/m2.lisp (original)
+++ branches/bos/projects/bos/m2/m2.lisp Fri Jan 18 11:44:59 2008
@@ -462,7 +462,8 @@
:directory directory
:subsystems (list (make-instance 'store-object-subsystem)
(make-instance 'blob-subsystem
- :n-blobs-per-directory 1000)))
+ :n-blobs-per-directory 1000)
+ (make-instance 'bos.m2.allocation-cache:allocation-cache-subsystem)))
(format t "~&; Startup der Quadratmeterdatenbank done.~%")
(force-output))
@@ -473,5 +474,7 @@
while (and (or (null percentage)
(< (allocation-area-percent-used (first (class-instances 'allocation-area))) percentage))
(make-contract sponsor
- (random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30)))
+ (random-elt (cons (1+ (random 300))
+ '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10
+ 10 10 10 10 10 30 30 30)))
:paidp t))))
\ No newline at end of file
Modified: branches/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp (original)
+++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 18 11:44:59 2008
@@ -233,5 +233,6 @@
#:add-area
#:free-regions-count
#:free-regions-pprint
- #:rebuild-cache))
+ #:rebuild-cache
+ #:allocation-cache-subsystem))
Modified: branches/bos/projects/bos/test/allocation-area.lisp
==============================================================================
--- branches/bos/projects/bos/test/allocation-area.lisp (original)
+++ branches/bos/projects/bos/test/allocation-area.lisp Fri Jan 18 11:44:59 2008
@@ -10,10 +10,19 @@
(finishes (make-allocation-rectangle 0 0 100 100))
(signals (error) (make-allocation-rectangle 0 0 100 100))))
-(test allocation-area.one-contract
+(test allocation-area.one-contract.no-cache
(with-fixture empty-store ()
(let ((area (make-allocation-rectangle 0 0 100 100))
(sponsor (make-sponsor :login "test-sponsor"))
(m2-count 10))
- (finishes (make-contract sponsor m2-count)))))
+ (finishes (make-contract sponsor m2-count))
+ (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area))))))
+
+(test allocation-area.one-contract.with-cache
+ (with-fixture empty-store ()
+ (let ((area (make-allocation-rectangle 0 0 2 5))
+ (sponsor (make-sponsor :login "test-sponsor"))
+ (m2-count 10))
+ (finishes (make-contract sponsor m2-count))
+ (is (zerop (allocation-area-free-m2s area))))))
Modified: branches/bos/projects/bos/test/fixtures.lisp
==============================================================================
--- branches/bos/projects/bos/test/fixtures.lisp (original)
+++ branches/bos/projects/bos/test/fixtures.lisp Fri Jan 18 11:44:59 2008
@@ -1,10 +1,11 @@
(in-package :bos.test)
-(def-fixture empty-store ()
- (bos.m2::reinit :delete t
- :directory #p"/tmp/test-store.tmp/"
- :website-url bos.m2::*website-url*)
+(def-fixture empty-store ()
(unwind-protect
- (&body)
+ (progn
+ (bos.m2::reinit :delete t
+ :directory #p"/tmp/test-store.tmp/"
+ :website-url bos.m2::*website-url*)
+ (&body))
(close-store)))
1
0
18 Jan '08
Author: ksprotte
Date: Fri Jan 18 11:03:44 2008
New Revision: 2356
Added:
branches/bos/projects/bos/test/allocation-area.lisp
branches/bos/projects/bos/test/fixtures.lisp
Modified:
branches/bos/projects/bos/Makefile
branches/bos/projects/bos/m2/m2.lisp
branches/bos/projects/bos/test/allocation-cache.lisp
branches/bos/projects/bos/test/bos.test.asd
branches/bos/projects/bos/test/packages.lisp
branches/bos/projects/bos/test/suites.lisp
Log:
a few tests are place; some fail...
Modified: branches/bos/projects/bos/Makefile
==============================================================================
--- branches/bos/projects/bos/Makefile (original)
+++ branches/bos/projects/bos/Makefile Fri Jan 18 11:03:44 2008
@@ -7,10 +7,15 @@
bos.core: cmucl.core build.sh load.lisp build.lisp
./build.sh
+# run with slime
+.PHONY: slime
+slime: bos.core
+ lisp -core bos.core -slime
+
# test
.PHONY: test
-test:
+test: bos.core
lisp -core bos.core -test -slime
# various cleaning stuff
@@ -40,3 +45,8 @@
make cleancore
make all
+# TAGS
+
+TAGS:
+ find . -name '*.lisp' | xargs etags -a
+
Modified: branches/bos/projects/bos/m2/m2.lisp
==============================================================================
--- branches/bos/projects/bos/m2/m2.lisp (original)
+++ branches/bos/projects/bos/m2/m2.lisp Fri Jan 18 11:03:44 2008
@@ -451,6 +451,10 @@
(setf *website-url* website-url)
(unless directory
(error ":DIRECTORY parameter not set in m2.rc"))
+ (assert (and (null (pathname-name directory))
+ (null (pathname-type directory)))
+ (directory)
+ ":DIRECTORY parameter is ~s (not a directory pathname)" directory)
(when delete
(delete-directory directory)
(assert (not (probe-file directory))))
Added: branches/bos/projects/bos/test/allocation-area.lisp
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/test/allocation-area.lisp Fri Jan 18 11:03:44 2008
@@ -0,0 +1,19 @@
+(in-package :bos.test)
+(in-suite :bos.test.allocation-area)
+
+(test allocation-area.none-at-startup
+ (with-fixture empty-store ()
+ (is (null (class-instances 'bos.m2:allocation-area)))))
+
+(test allocation-area.no-intersection
+ (with-fixture empty-store ()
+ (finishes (make-allocation-rectangle 0 0 100 100))
+ (signals (error) (make-allocation-rectangle 0 0 100 100))))
+
+(test allocation-area.one-contract
+ (with-fixture empty-store ()
+ (let ((area (make-allocation-rectangle 0 0 100 100))
+ (sponsor (make-sponsor :login "test-sponsor"))
+ (m2-count 10))
+ (finishes (make-contract sponsor m2-count)))))
+
Modified: branches/bos/projects/bos/test/allocation-cache.lisp
==============================================================================
--- branches/bos/projects/bos/test/allocation-cache.lisp (original)
+++ branches/bos/projects/bos/test/allocation-cache.lisp Fri Jan 18 11:03:44 2008
@@ -1,9 +1,7 @@
(in-package :bos.test)
(in-suite :bos.test.allocation-cache)
-(test dummy
- (is (= 1 1)))
-
-(test dummy.2
- (is (= 1 2)))
+(test allocation-cache.present
+ (with-fixture empty-store ()
+ (finishes (bos.m2.allocation-cache:find-exact-match 1))))
Modified: branches/bos/projects/bos/test/bos.test.asd
==============================================================================
--- branches/bos/projects/bos/test/bos.test.asd (original)
+++ branches/bos/projects/bos/test/bos.test.asd Fri Jan 18 11:03:44 2008
@@ -5,6 +5,8 @@
:depends-on (:bos.web :fiveam)
:components ((:file "packages")
(:file "suites" :depends-on ("packages"))
- (:file "allocation-cache" :depends-on ("suites"))
+ (:file "fixtures" :depends-on ("packages"))
+ (:file "allocation-area" :depends-on ("suites" "fixtures"))
+ (:file "allocation-cache" :depends-on ("suites" "fixtures"))
;; (:file "utils" :depends-on ("config"))
))
Added: branches/bos/projects/bos/test/fixtures.lisp
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/test/fixtures.lisp Fri Jan 18 11:03:44 2008
@@ -0,0 +1,10 @@
+(in-package :bos.test)
+
+(def-fixture empty-store ()
+ (bos.m2::reinit :delete t
+ :directory #p"/tmp/test-store.tmp/"
+ :website-url bos.m2::*website-url*)
+ (unwind-protect
+ (&body)
+ (close-store)))
+
Modified: branches/bos/projects/bos/test/packages.lisp
==============================================================================
--- branches/bos/projects/bos/test/packages.lisp (original)
+++ branches/bos/projects/bos/test/packages.lisp Fri Jan 18 11:03:44 2008
@@ -13,6 +13,7 @@
:bknr.images
:bknr.statistics
:bknr.rss
+ :bos.m2
:bos.m2.config
))
Modified: branches/bos/projects/bos/test/suites.lisp
==============================================================================
--- branches/bos/projects/bos/test/suites.lisp (original)
+++ branches/bos/projects/bos/test/suites.lisp Fri Jan 18 11:03:44 2008
@@ -3,6 +3,10 @@
(def-suite :bos.test
:description "The root suite. Contains all tests.")
+(def-suite :bos.test.allocation-area
+ :in :bos.test
+ :description "Some basic tests for allocation-area.")
+
(def-suite :bos.test.allocation-cache
:in :bos.test
:description "Tests for the newly introduced allocation-cache.")
1
0
18 Jan '08
Author: ksprotte
Date: Fri Jan 18 10:05:07 2008
New Revision: 2355
Added:
branches/bos/projects/bos/test/
branches/bos/projects/bos/test/allocation-cache.lisp
branches/bos/projects/bos/test/bos.test.asd
branches/bos/projects/bos/test/packages.lisp
branches/bos/projects/bos/test/suites.lisp
Modified:
branches/bos/projects/bos/Makefile
branches/bos/projects/bos/build.lisp
Log:
basic test-suite setup; run: make test
Modified: branches/bos/projects/bos/Makefile
==============================================================================
--- branches/bos/projects/bos/Makefile (original)
+++ branches/bos/projects/bos/Makefile Fri Jan 18 10:05:07 2008
@@ -4,9 +4,16 @@
cmucl.core:
lisp -load make-base-lisp.lisp
-bos.core: cmucl.core
+bos.core: cmucl.core build.sh load.lisp build.lisp
./build.sh
+# test
+
+.PHONY: test
+test:
+ lisp -core bos.core -test -slime
+
+# various cleaning stuff
.PHONY: cleancore
cleancore:
rm -f cmucl.core
Modified: branches/bos/projects/bos/build.lisp
==============================================================================
--- branches/bos/projects/bos/build.lisp (original)
+++ branches/bos/projects/bos/build.lisp Fri Jan 18 10:05:07 2008
@@ -2,7 +2,11 @@
(handler-bind ((style-warning #'muffle-warning))
(asdf:operate 'asdf:load-op :aserve)
- (asdf:operate 'asdf:load-op :bos.web))
+ (asdf:operate 'asdf:load-op :bos.web)
+ ;; FIXME: fuer das Deployment ?
+ ;; BOS tests
+ (asdf:operate 'asdf:load-op :fiveam)
+ (asdf:oos 'asdf:load-op :bos.test))
;;;
;;; Lisp-Image fuer das Deployment dumpen
@@ -25,6 +29,7 @@
(define-toggle-switch "nostart" *webserver* t)
(define-toggle-switch "slime" *slime* nil)
(define-toggle-switch "cert-daemon" *cert-daemon* nil)
+(define-toggle-switch "test" *run-tests* nil)
(defun start-webserver ()
(apply #'bos.m2::reinit (read-configuration "m2.rc"))
@@ -54,6 +59,13 @@
(fix-dpd)
(asdf:oos 'asdf:load-op :bos.web)
(format t "BOS Online-System~%")
+ (when *run-tests*
+ (asdf:oos 'asdf:load-op :bos.test)
+ (format t "Starting BOS tests...~%")
+ (eval (read-from-string "(5am:run! :bos.test)"))
+ (terpri)
+ (finish-output)
+ (cl-user::quit))
(when *cert-daemon*
(format t "; starting certificate generation daemon, slime and webserver not started~%")
(bos.m2.cert-generator:cert-daemon))
@@ -61,9 +73,13 @@
(start-slime))
(when *webserver*
(start-webserver))
- (if (or *slime* *webserver*)
- (mp::startup-idle-and-top-level-loops))
- (lisp::%top-level))
+ (cond
+ (*run-tests*
+ (asdf:oos 'asdf:load-op :bos.test)
+ (eval (read-from-string "(5am:run! :bos.test)")))
+ (t (when (or *slime* *webserver*)
+ (mp::startup-idle-and-top-level-loops))
+ (lisp::%top-level))))
(setf *default-pathname-defaults* #p"")
(when (probe-file "bos.core")
Added: branches/bos/projects/bos/test/allocation-cache.lisp
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/test/allocation-cache.lisp Fri Jan 18 10:05:07 2008
@@ -0,0 +1,9 @@
+(in-package :bos.test)
+(in-suite :bos.test.allocation-cache)
+
+(test dummy
+ (is (= 1 1)))
+
+(test dummy.2
+ (is (= 1 2)))
+
Added: branches/bos/projects/bos/test/bos.test.asd
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/test/bos.test.asd Fri Jan 18 10:05:07 2008
@@ -0,0 +1,10 @@
+(in-package :cl-user)
+
+(asdf:defsystem :bos.test
+ :description "BOS Online-System test-suite"
+ :depends-on (:bos.web :fiveam)
+ :components ((:file "packages")
+ (:file "suites" :depends-on ("packages"))
+ (:file "allocation-cache" :depends-on ("suites"))
+ ;; (:file "utils" :depends-on ("config"))
+ ))
Added: branches/bos/projects/bos/test/packages.lisp
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/test/packages.lisp Fri Jan 18 10:05:07 2008
@@ -0,0 +1,18 @@
+(defpackage :bos.test
+ (:use :cl
+ :fiveam
+ :iterate
+ ;; maybe later
+ ;; :cl-ppcre
+ ;; :cl-interpol
+ :bknr.utils
+ :bknr.indices
+ :bknr.datastore
+ :bknr.user
+ :bknr.web
+ :bknr.images
+ :bknr.statistics
+ :bknr.rss
+ :bos.m2.config
+ ))
+
Added: branches/bos/projects/bos/test/suites.lisp
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/test/suites.lisp Fri Jan 18 10:05:07 2008
@@ -0,0 +1,9 @@
+(in-package :bos.test)
+
+(def-suite :bos.test
+ :description "The root suite. Contains all tests.")
+
+(def-suite :bos.test.allocation-cache
+ :in :bos.test
+ :description "Tests for the newly introduced allocation-cache.")
+
1
0
[bknr-cvs] r2354 - in branches/bos/thirdparty: emacs/slime slime
by hhubner＠common-lisp.net 18 Jan '08
by hhubner＠common-lisp.net 18 Jan '08
18 Jan '08
Author: hhubner
Date: Fri Jan 18 07:07:26 2008
New Revision: 2354
Added:
branches/bos/thirdparty/slime/
- copied from r2353, branches/bos/thirdparty/emacs/slime/
Removed:
branches/bos/thirdparty/emacs/slime/
Log:
move slime to thirdparty-toplevel (has been there, please don't move it to emacs/ again
1
0
[bknr-cvs] r2353 - in branches/bos: bknr/src/web projects/bos/web
by hhubner＠common-lisp.net 18 Jan '08
by hhubner＠common-lisp.net 18 Jan '08
18 Jan '08
Author: hhubner
Date: Fri Jan 18 07:05:32 2008
New Revision: 2353
Modified:
branches/bos/bknr/src/web/handlers.lisp
branches/bos/bknr/src/web/web-utils.lisp
branches/bos/projects/bos/web/tags.lisp
branches/bos/projects/bos/web/webserver.lisp
Log:
redirect with http response code 301 instead of 302, hoping that it will make google analytics happy
Modified: branches/bos/bknr/src/web/handlers.lisp
==============================================================================
--- branches/bos/bknr/src/web/handlers.lisp (original)
+++ branches/bos/bknr/src/web/handlers.lisp Fri Jan 18 07:05:32 2008
@@ -259,7 +259,7 @@
((to :initarg :to :reader redirect-handler-to :documentation "url to redirect to")))
(defmethod handle ((page-handler redirect-handler) req)
- (redirect (redirect-handler-to page-handler) req))
+ (redirect (redirect-handler-to page-handler) req *response-moved-permanently*))
(defclass random-redirect-handler (redirect-handler)
())
Modified: branches/bos/bknr/src/web/web-utils.lisp
==============================================================================
--- branches/bos/bknr/src/web/web-utils.lisp (original)
+++ branches/bos/bknr/src/web/web-utils.lisp Fri Jan 18 07:05:32 2008
@@ -16,8 +16,8 @@
(with-http-body (req *ent*)
(html "The page you requested could not be found."))))
-(defun redirect (to req)
- (with-bknr-http-response (req :response *response-found*)
+(defun redirect (to req &optional (response-code *response-found*))
+ (with-bknr-http-response (req :response response-code)
(setf (reply-header-slot-value req :location) to)
(with-http-body (req *ent*))))
Modified: branches/bos/projects/bos/web/tags.lisp
==============================================================================
--- branches/bos/projects/bos/web/tags.lisp (original)
+++ branches/bos/projects/bos/web/tags.lisp Fri Jan 18 07:05:32 2008
@@ -176,4 +176,4 @@
"var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.');
document.write(unescape('%3Cscript src=%22' + gaJsHost + 'google-analytics.com/ga.js%22 type=%22text/javascript%22%3E%3C/script%3E'));")
((:script :type "text/javascript")
- #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }")))
+ (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }"))))
Modified: branches/bos/projects/bos/web/webserver.lisp
==============================================================================
--- branches/bos/projects/bos/web/webserver.lisp (original)
+++ branches/bos/projects/bos/web/webserver.lisp Fri Jan 18 07:05:32 2008
@@ -94,7 +94,8 @@
(defmethod handle ((handler index-handler) req)
(redirect (format nil "/~A/index" (or (find-browser-prefered-language req)
*default-language*))
- req))
+ req
+ *response-moved-permanently*))
(defclass infosystem-handler (page-handler)
())
1
0
Author: ksprotte
Date: Fri Jan 18 06:33:37 2008
New Revision: 2352
Modified:
branches/bos/projects/bos/build.lisp
Log:
changed start-slime for new slime
Modified: branches/bos/projects/bos/build.lisp
==============================================================================
--- branches/bos/projects/bos/build.lisp (original)
+++ branches/bos/projects/bos/build.lisp Fri Jan 18 06:33:37 2008
@@ -32,7 +32,8 @@
(bknr.cron::start-cron))
(defun start-slime ()
- (swank::create-swank-server 4005 :spawn #'swank::simple-announce-function t))
+ ;; (swank::create-swank-server 4005 :spawn #'swank::simple-announce-function t)
+ (swank:create-server :port 4005 :dont-close t))
(defun reload-global-table ()
(loop for lib-entry in (reverse sys::*global-table*)
1
0
[bknr-cvs] r2351 - in branches/bos/projects/bos: payment-website/templates/da payment-website/templates/de payment-website/templates/en web
by hhubner＠common-lisp.net 18 Jan '08
by hhubner＠common-lisp.net 18 Jan '08
18 Jan '08
Author: hhubner
Date: Fri Jan 18 06:14:31 2008
New Revision: 2351
Modified:
branches/bos/projects/bos/payment-website/templates/da/infosystem.xml
branches/bos/projects/bos/payment-website/templates/da/profil.xml
branches/bos/projects/bos/payment-website/templates/da/quittung.xml
branches/bos/projects/bos/payment-website/templates/da/ring-detail.xml
branches/bos/projects/bos/payment-website/templates/da/sponsor_canceled.xml
branches/bos/projects/bos/payment-website/templates/da/toplevel.xml
branches/bos/projects/bos/payment-website/templates/da/toplevel_extra.xml
branches/bos/projects/bos/payment-website/templates/da/toplevel_main.xml
branches/bos/projects/bos/payment-website/templates/da/versand_geschenk.xml
branches/bos/projects/bos/payment-website/templates/da/versand_info.xml
branches/bos/projects/bos/payment-website/templates/de/infosystem.xml
branches/bos/projects/bos/payment-website/templates/de/profil.xml
branches/bos/projects/bos/payment-website/templates/de/quittung.xml
branches/bos/projects/bos/payment-website/templates/de/ring-detail.xml
branches/bos/projects/bos/payment-website/templates/de/sponsor_canceled.xml
branches/bos/projects/bos/payment-website/templates/de/toplevel.xml
branches/bos/projects/bos/payment-website/templates/de/toplevel_extra.xml
branches/bos/projects/bos/payment-website/templates/de/toplevel_main.xml
branches/bos/projects/bos/payment-website/templates/de/toplevel_news.xml
branches/bos/projects/bos/payment-website/templates/de/versand_geschenk.xml
branches/bos/projects/bos/payment-website/templates/de/versand_info.xml
branches/bos/projects/bos/payment-website/templates/en/infosystem.xml
branches/bos/projects/bos/payment-website/templates/en/profil.xml
branches/bos/projects/bos/payment-website/templates/en/quittung.xml
branches/bos/projects/bos/payment-website/templates/en/ring-detail.xml
branches/bos/projects/bos/payment-website/templates/en/sponsor_canceled.xml
branches/bos/projects/bos/payment-website/templates/en/toplevel.xml
branches/bos/projects/bos/payment-website/templates/en/toplevel_extra.xml
branches/bos/projects/bos/payment-website/templates/en/toplevel_main.xml
branches/bos/projects/bos/payment-website/templates/en/versand_geschenk.xml
branches/bos/projects/bos/payment-website/templates/en/versand_info.xml
branches/bos/projects/bos/web/config.lisp
branches/bos/projects/bos/web/startup.lisp
branches/bos/projects/bos/web/tags.lisp
Log:
Add page tracking with Google Analytics.
Modified: branches/bos/projects/bos/payment-website/templates/da/infosystem.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/infosystem.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/infosystem.xml Fri Jan 18 06:14:31 2008
@@ -17,5 +17,6 @@
<div id="content_infosystem">
<h1 class="extra">Infosystem "satelit kort"</h1>
</div>
+<bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/profil.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/profil.xml Fri Jan 18 06:14:31 2008
@@ -119,5 +119,6 @@
</table>
</form>
</bos:save-profile>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/quittung.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/quittung.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/quittung.xml Fri Jan 18 06:14:31 2008
@@ -157,5 +157,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/ring-detail.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/ring-detail.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/ring-detail.xml Fri Jan 18 06:14:31 2008
@@ -24,5 +24,6 @@
close window
</a>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/sponsor_canceled.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/sponsor_canceled.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/sponsor_canceled.xml Fri Jan 18 06:14:31 2008
@@ -94,5 +94,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/toplevel.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/toplevel.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/toplevel.xml Fri Jan 18 06:14:31 2008
@@ -66,5 +66,6 @@
<bknr:tag-body></bknr:tag-body>
<!-- /content 3teilig-->
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/toplevel_extra.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/toplevel_extra.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/toplevel_extra.xml Fri Jan 18 06:14:31 2008
@@ -22,5 +22,6 @@
luk vindue
</a>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/toplevel_main.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/toplevel_main.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/toplevel_main.xml Fri Jan 18 06:14:31 2008
@@ -152,5 +152,6 @@
<bknr:tag-body></bknr:tag-body>
<!-- /content 3teilig-->
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/versand_geschenk.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/versand_geschenk.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/versand_geschenk.xml Fri Jan 18 06:14:31 2008
@@ -180,5 +180,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/da/versand_info.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/versand_info.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/da/versand_info.xml Fri Jan 18 06:14:31 2008
@@ -172,5 +172,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/infosystem.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/infosystem.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/infosystem.xml Fri Jan 18 06:14:31 2008
@@ -18,6 +18,7 @@
<div id="content_infosystem">
<h1 class="extra">Infosystem "rund um das Satellitenbild"</h1>
</div>
+<bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/profil.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/profil.xml Fri Jan 18 06:14:31 2008
@@ -124,5 +124,6 @@
</table>
</form>
</bos:save-profile>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/quittung.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/quittung.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/quittung.xml Fri Jan 18 06:14:31 2008
@@ -166,5 +166,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/ring-detail.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/ring-detail.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/ring-detail.xml Fri Jan 18 06:14:31 2008
@@ -21,8 +21,9 @@
<div style="padding:10px">
<img src="/images/pfeil_link_on.gif" width="10" height="9" border="0" alt="" />
<a href="javascript:window.close()" class="more">
- Fenster schließen
+ Fenster schlieÃen
</a>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/sponsor_canceled.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/sponsor_canceled.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/sponsor_canceled.xml Fri Jan 18 06:14:31 2008
@@ -105,5 +105,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/toplevel.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/toplevel.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/toplevel.xml Fri Jan 18 06:14:31 2008
@@ -74,5 +74,6 @@
<bknr:tag-body />
<!-- /content 3teilig-->
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/toplevel_extra.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/toplevel_extra.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/toplevel_extra.xml Fri Jan 18 06:14:31 2008
@@ -24,8 +24,9 @@
<div style="padding:10px">
<img src="/images/pfeil_link_on.gif" width="10" height="9" border="0" alt="" />
<a href="javascript:window.close()" class="more">
- Fenster schließen
+ Fenster schlieÃen
</a>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/toplevel_main.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/toplevel_main.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/toplevel_main.xml Fri Jan 18 06:14:31 2008
@@ -194,5 +194,6 @@
<bknr:tag-body />
<!-- /content 3teilig-->
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/toplevel_news.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/toplevel_news.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/toplevel_news.xml Fri Jan 18 06:14:31 2008
@@ -192,5 +192,6 @@
<bknr:tag-body />
<!-- /content 3teilig-->
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/versand_geschenk.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/versand_geschenk.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/versand_geschenk.xml Fri Jan 18 06:14:31 2008
@@ -180,5 +180,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/de/versand_info.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/versand_info.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/de/versand_info.xml Fri Jan 18 06:14:31 2008
@@ -183,5 +183,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/infosystem.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/infosystem.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/infosystem.xml Fri Jan 18 06:14:31 2008
@@ -18,6 +18,7 @@
<div id="content_infosystem">
<h1 class="extra">Infosystem "satellite map"</h1>
</div>
+<bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/profil.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/profil.xml Fri Jan 18 06:14:31 2008
@@ -124,5 +124,6 @@
</table>
</form>
</bos:save-profile>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/quittung.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/quittung.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/quittung.xml Fri Jan 18 06:14:31 2008
@@ -166,5 +166,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/ring-detail.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/ring-detail.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/ring-detail.xml Fri Jan 18 06:14:31 2008
@@ -24,5 +24,6 @@
close window
</a>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/sponsor_canceled.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/sponsor_canceled.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/sponsor_canceled.xml Fri Jan 18 06:14:31 2008
@@ -105,5 +105,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/toplevel.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/toplevel.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/toplevel.xml Fri Jan 18 06:14:31 2008
@@ -76,5 +76,6 @@
<bknr:tag-body />
<!-- /content 3teilig-->
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/toplevel_extra.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/toplevel_extra.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/toplevel_extra.xml Fri Jan 18 06:14:31 2008
@@ -27,5 +27,6 @@
close window
</a>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/toplevel_main.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/toplevel_main.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/toplevel_main.xml Fri Jan 18 06:14:31 2008
@@ -192,5 +192,6 @@
<bknr:tag-body />
<!-- /content 3teilig-->
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/versand_geschenk.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/versand_geschenk.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/versand_geschenk.xml Fri Jan 18 06:14:31 2008
@@ -180,5 +180,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/payment-website/templates/en/versand_info.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/versand_info.xml (original)
+++ branches/bos/projects/bos/payment-website/templates/en/versand_info.xml Fri Jan 18 06:14:31 2008
@@ -181,5 +181,6 @@
</div>
</div>
</div>
+ <bos:google-analytics-track />
</body>
</html>
Modified: branches/bos/projects/bos/web/config.lisp
==============================================================================
--- branches/bos/projects/bos/web/config.lisp (original)
+++ branches/bos/projects/bos/web/config.lisp Fri Jan 18 06:14:31 2008
@@ -1,12 +1,15 @@
(in-package :bos.web)
-;; Worldpay (headcraft inst id ist 102532
+;; Worldpay installation ID
(defparameter *worldpay-installation-id* 103530
"Installation-ID für Worldpay")
;; Worldpay Test Mode
(defparameter *worldpay-test-mode* t)
+;; Account fuer Google Analytics
+(defparameter *google-analytics-account* "UA-3432040-2")
+
;; URL für BASE HREFs
(defparameter *website-url* "http://create-rainforest.org")
Modified: branches/bos/projects/bos/web/startup.lisp
==============================================================================
--- branches/bos/projects/bos/web/startup.lisp (original)
+++ branches/bos/projects/bos/web/startup.lisp Fri Jan 18 06:14:31 2008
@@ -16,13 +16,20 @@
(defvar *website-url*)
(defvar *worldpay-test-mode*)
-(defun init (&key (port 8080) (listeners 1) (vhosts '("localhost")) website-directory website-url worldpay-test-mode)
+(defun init (&key (port 8080)
+ (listeners 1)
+ (vhosts '("localhost"))
+ website-directory
+ website-url
+ worldpay-test-mode
+ google-analytics-account)
(setf *port* port)
(setf *listeners* listeners)
(setf *vhosts* vhosts)
(setf *website-url* website-url)
(setf *website-directory* website-directory)
(setf *worldpay-test-mode* worldpay-test-mode)
+ (setf *google-analytics-account* google-analytics-account)
(unless *website-directory*
(error ":website-directory not specified"))
(reinit))
Modified: branches/bos/projects/bos/web/tags.lisp
==============================================================================
--- branches/bos/projects/bos/web/tags.lisp (original)
+++ branches/bos/projects/bos/web/tags.lisp Fri Jan 18 06:14:31 2008
@@ -169,4 +169,11 @@
(define-bknr-tag admin-login-page (&key children)
(if (editor-p (bknr-request-user (get-template-var :request)))
(html (:head ((:meta :http-equiv "refresh" :content "0; url=/admin"))))
- (mapc #'emit-template-node children)))
\ No newline at end of file
+ (mapc #'emit-template-node children)))
+
+(define-bknr-tag google-analytics-track ()
+ (html ((:script :type "text/javascript")
+ "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.');
+document.write(unescape('%3Cscript src=%22' + gaJsHost + 'google-analytics.com/ga.js%22 type=%22text/javascript%22%3E%3C/script%3E'));")
+ ((:script :type "text/javascript")
+ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }")))
1
0
[bknr-cvs] r2350 - in branches/bos/thirdparty/emacs/slime: . CVS contrib contrib/CVS doc doc/CVS
by ksprotte＠common-lisp.net 18 Jan '08
by ksprotte＠common-lisp.net 18 Jan '08
18 Jan '08
Author: ksprotte
Date: Fri Jan 18 06:05:59 2008
New Revision: 2350
Added:
branches/bos/thirdparty/emacs/slime/
branches/bos/thirdparty/emacs/slime/.cvsignore
branches/bos/thirdparty/emacs/slime/CVS/
branches/bos/thirdparty/emacs/slime/CVS/Entries
branches/bos/thirdparty/emacs/slime/CVS/Entries.Log
branches/bos/thirdparty/emacs/slime/CVS/Repository
branches/bos/thirdparty/emacs/slime/CVS/Root
branches/bos/thirdparty/emacs/slime/CVS/Template
branches/bos/thirdparty/emacs/slime/ChangeLog
branches/bos/thirdparty/emacs/slime/HACKING
branches/bos/thirdparty/emacs/slime/NEWS
branches/bos/thirdparty/emacs/slime/PROBLEMS
branches/bos/thirdparty/emacs/slime/README
branches/bos/thirdparty/emacs/slime/contrib/
branches/bos/thirdparty/emacs/slime/contrib/CVS/
branches/bos/thirdparty/emacs/slime/contrib/CVS/Entries
branches/bos/thirdparty/emacs/slime/contrib/CVS/Repository
branches/bos/thirdparty/emacs/slime/contrib/CVS/Root
branches/bos/thirdparty/emacs/slime/contrib/CVS/Template
branches/bos/thirdparty/emacs/slime/contrib/ChangeLog
branches/bos/thirdparty/emacs/slime/contrib/README
branches/bos/thirdparty/emacs/slime/contrib/bridge.el
branches/bos/thirdparty/emacs/slime/contrib/inferior-slime.el
branches/bos/thirdparty/emacs/slime/contrib/slime-asdf.el
branches/bos/thirdparty/emacs/slime/contrib/slime-autodoc.el
branches/bos/thirdparty/emacs/slime/contrib/slime-banner.el
branches/bos/thirdparty/emacs/slime/contrib/slime-c-p-c.el
branches/bos/thirdparty/emacs/slime/contrib/slime-editing-commands.el
branches/bos/thirdparty/emacs/slime/contrib/slime-fancy-inspector.el
branches/bos/thirdparty/emacs/slime/contrib/slime-fancy.el
branches/bos/thirdparty/emacs/slime/contrib/slime-fuzzy.el
branches/bos/thirdparty/emacs/slime/contrib/slime-highlight-edits.el
branches/bos/thirdparty/emacs/slime/contrib/slime-parse.el
branches/bos/thirdparty/emacs/slime/contrib/slime-presentation-streams.el
branches/bos/thirdparty/emacs/slime/contrib/slime-presentations.el
branches/bos/thirdparty/emacs/slime/contrib/slime-references.el
branches/bos/thirdparty/emacs/slime/contrib/slime-scheme.el
branches/bos/thirdparty/emacs/slime/contrib/slime-scratch.el
branches/bos/thirdparty/emacs/slime/contrib/slime-tramp.el
branches/bos/thirdparty/emacs/slime/contrib/slime-typeout-frame.el
branches/bos/thirdparty/emacs/slime/contrib/slime-xref-browser.el
branches/bos/thirdparty/emacs/slime/contrib/swank-arglists.lisp
branches/bos/thirdparty/emacs/slime/contrib/swank-asdf.lisp
branches/bos/thirdparty/emacs/slime/contrib/swank-c-p-c.lisp
branches/bos/thirdparty/emacs/slime/contrib/swank-fancy-inspector.lisp
branches/bos/thirdparty/emacs/slime/contrib/swank-fuzzy.lisp
branches/bos/thirdparty/emacs/slime/contrib/swank-listener-hooks.lisp
branches/bos/thirdparty/emacs/slime/contrib/swank-presentation-streams.lisp
branches/bos/thirdparty/emacs/slime/contrib/swank-presentations.lisp
branches/bos/thirdparty/emacs/slime/doc/
branches/bos/thirdparty/emacs/slime/doc/.cvsignore
branches/bos/thirdparty/emacs/slime/doc/CVS/
branches/bos/thirdparty/emacs/slime/doc/CVS/Entries
branches/bos/thirdparty/emacs/slime/doc/CVS/Repository
branches/bos/thirdparty/emacs/slime/doc/CVS/Root
branches/bos/thirdparty/emacs/slime/doc/CVS/Template
branches/bos/thirdparty/emacs/slime/doc/Makefile
branches/bos/thirdparty/emacs/slime/doc/slime-refcard.pdf (contents, props changed)
branches/bos/thirdparty/emacs/slime/doc/slime-refcard.tex
branches/bos/thirdparty/emacs/slime/doc/slime-small.eps
branches/bos/thirdparty/emacs/slime/doc/slime-small.pdf (contents, props changed)
branches/bos/thirdparty/emacs/slime/doc/slime.texi
branches/bos/thirdparty/emacs/slime/doc/texinfo-tabulate.awk
branches/bos/thirdparty/emacs/slime/hyperspec.el
branches/bos/thirdparty/emacs/slime/metering.lisp
branches/bos/thirdparty/emacs/slime/mkdist.sh (contents, props changed)
branches/bos/thirdparty/emacs/slime/nregex.lisp
branches/bos/thirdparty/emacs/slime/sbcl-pprint-patch.lisp
branches/bos/thirdparty/emacs/slime/slime-autoloads.el
branches/bos/thirdparty/emacs/slime/slime.el
branches/bos/thirdparty/emacs/slime/swank-abcl.lisp
branches/bos/thirdparty/emacs/slime/swank-allegro.lisp
branches/bos/thirdparty/emacs/slime/swank-backend.lisp
branches/bos/thirdparty/emacs/slime/swank-clisp.lisp
branches/bos/thirdparty/emacs/slime/swank-cmucl.lisp
branches/bos/thirdparty/emacs/slime/swank-corman.lisp
branches/bos/thirdparty/emacs/slime/swank-ecl.lisp
branches/bos/thirdparty/emacs/slime/swank-gray.lisp
branches/bos/thirdparty/emacs/slime/swank-lispworks.lisp
branches/bos/thirdparty/emacs/slime/swank-loader.lisp
branches/bos/thirdparty/emacs/slime/swank-openmcl.lisp
branches/bos/thirdparty/emacs/slime/swank-sbcl.lisp
branches/bos/thirdparty/emacs/slime/swank-scl.lisp
branches/bos/thirdparty/emacs/slime/swank-source-file-cache.lisp
branches/bos/thirdparty/emacs/slime/swank-source-path-parser.lisp
branches/bos/thirdparty/emacs/slime/swank.asd
branches/bos/thirdparty/emacs/slime/swank.lisp
branches/bos/thirdparty/emacs/slime/test-all.sh (contents, props changed)
branches/bos/thirdparty/emacs/slime/test.sh (contents, props changed)
branches/bos/thirdparty/emacs/slime/xref.lisp
Log:
Added newest SLIME (needed by FiveAM -> arnesi -> slime)
Added: branches/bos/thirdparty/emacs/slime/.cvsignore
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/.cvsignore Fri Jan 18 06:05:59 2008
@@ -0,0 +1,6 @@
+*.x86f
+*.fasl
+*.dfsl
+*.lx64fsl
+*.elc
+_darcs
Added: branches/bos/thirdparty/emacs/slime/CVS/Entries
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/CVS/Entries Fri Jan 18 06:05:59 2008
@@ -0,0 +1,34 @@
+/.cvsignore/1.5/Sun Apr 8 19:23:57 2007//
+/ChangeLog/1.1268/Thu Jan 17 05:53:44 2008//
+/HACKING/1.8/Wed Sep 19 11:08:27 2007//
+/NEWS/1.9/Tue Nov 27 11:50:13 2007//
+/PROBLEMS/1.8/Sun Nov 20 23:31:56 2005//
+/README/1.14/Tue Oct 3 21:49:13 2006//
+/hyperspec.el/1.11/Thu Dec 7 07:36:54 2006//
+/metering.lisp/1.4/Fri Apr 1 20:16:35 2005//
+/mkdist.sh/1.7/Mon Aug 29 20:02:58 2005//
+/nregex.lisp/1.4/Mon Sep 19 08:20:48 2005//
+/sbcl-pprint-patch.lisp/1.1/Fri Feb 17 01:30:21 2006//
+/slime-autoloads.el/1.3/Thu Sep 20 14:59:08 2007//
+/slime.el/1.892/Mon Jan 14 12:08:44 2008//
+/swank-abcl.lisp/1.44/Mon Oct 22 08:36:32 2007//
+/swank-allegro.lisp/1.98/Wed Sep 26 23:15:41 2007//
+/swank-backend.lisp/1.126/Mon Sep 10 15:39:05 2007//
+/swank-clisp.lisp/1.64/Thu Aug 23 19:03:37 2007//
+/swank-cmucl.lisp/1.175/Fri Nov 30 13:10:40 2007//
+/swank-corman.lisp/1.11/Thu Aug 23 19:03:37 2007//
+/swank-ecl.lisp/1.10/Sat Dec 22 02:53:58 2007//
+/swank-gray.lisp/1.10/Wed Apr 12 08:43:55 2006//
+/swank-lispworks.lisp/1.93/Sat Nov 24 08:18:59 2007//
+/swank-loader.lisp/1.75/Sat Nov 24 08:18:59 2007//
+/swank-openmcl.lisp/1.120/Mon Oct 22 08:19:58 2007//
+/swank-sbcl.lisp/1.187/Thu Jan 17 05:53:44 2008//
+/swank-scl.lisp/1.14/Sat Dec 22 13:24:49 2007//
+/swank-source-file-cache.lisp/1.8/Tue Dec 5 13:00:42 2006//
+/swank-source-path-parser.lisp/1.17/Sun Jun 25 08:33:16 2006//
+/swank.asd/1.5/Fri Sep 14 12:41:28 2007//
+/swank.lisp/1.523/Thu Dec 20 10:33:37 2007//
+/test-all.sh/1.2/Mon Aug 29 20:02:58 2005//
+/test.sh/1.9/Mon Aug 27 13:16:49 2007//
+/xref.lisp/1.2/Mon May 17 00:25:24 2004//
+D
Added: branches/bos/thirdparty/emacs/slime/CVS/Entries.Log
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/CVS/Entries.Log Fri Jan 18 06:05:59 2008
@@ -0,0 +1,2 @@
+A D/contrib////
+A D/doc////
Added: branches/bos/thirdparty/emacs/slime/CVS/Repository
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/CVS/Repository Fri Jan 18 06:05:59 2008
@@ -0,0 +1 @@
+slime
Added: branches/bos/thirdparty/emacs/slime/CVS/Root
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/CVS/Root Fri Jan 18 06:05:59 2008
@@ -0,0 +1 @@
+:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot
Added: branches/bos/thirdparty/emacs/slime/CVS/Template
==============================================================================
Added: branches/bos/thirdparty/emacs/slime/ChangeLog
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/ChangeLog Fri Jan 18 06:05:59 2008
@@ -0,0 +1,13454 @@
+2008-01-17 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank-sbcl.lisp (sbcl-source-file-p): When a buffer is not
+ associated with any file, M-. for names defined there ends up
+ calling SBCL-SOURCE-FILE-P with NIL -- guard against that.
+
+2008-01-14 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (sldb-mode): Add `sldb-quit' to `kill-buffer-hook' to
+ close the debugging machinery on swank side when the SLDB buffer
+ is killed. (Notice that killing the SLDB buffer manually will not
+ restore window configuration in contrast to typing `q'.)
+
+2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-delete-and-extract-region): New
+ function. Portable version of `delete-and-extract-region' which
+ returned NIL instead of "", as experienced by Matthias Koeppe.
+
+2008-01-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-mode-map): Bind C-c C-t to
+ slime-toggle-trace-fdefinition (as in Lisp buffers) instead of
+ slime-repl-clear-buffer. This binding is useful for untracing
+ functions directly from the trace output. Move
+ slime-repl-clear-buffer to the keybinding C-c M-o.
+
+2008-01-04 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (source-file-source-location): Use the
+ debootstrap readtable when appropriate (fixes occasional reader
+ errors when using "v" on debugger frames that point to functions
+ defined in SBCL). Likewise for the debootstrapping packages.
+ (code-location-debug-source-name): Ensure that we always return a
+ physical namestring, Emacs won't like a pathname or a logical
+ namestring.
+
+2008-01-02 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ Use sane default values for slime-repl-set-package.
+
+ Previously, when typing `,!p' at the REPL, the current package
+ would have been inserted as a default (although the whole intent
+ was to /change/ the current package in the first place), now
+ nothing is inserted anymore.
+
+ * slime.el (slime-pretty-current-package): rename it to
+ slime-pretty-find-buffer-package and make it use
+ slime-find-buffer-package instead of slime-current-package.
+ (slime-repl-set-package, slime-set-package): use new function.
+
+2008-01-02 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-print-apropos): Simplified: Don't insert action
+ properties anymore for the symbol; they were ignored anyway,
+ because `apropos-follow' (bound to RET in the resulting
+ *SLIME Apropos* buffer) looks for buttons only.
+
+2008-01-02 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-apropos): Update docstring: Apropos doesn't
+ match on regular expressions anymore since 2007-11-24.
+
+2007-12-22 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl.lisp (set-stream-timeout, make-socket-io-stream): update
+ for Scieneer CL 1.3.7.
+
+2007-12-20 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (read-softly-from-string): Now actually returns all
+ three values as explained in its docstring.
+
+2007-12-14 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-insert-xref-location): New function. Tries to
+ either insert the file name a function is defined in, or inserts
+ information about the buffer a function was interactively
+ `C-c C-c'd from. Idea from Knut Olav B�hmer.
+ (slime-insert-xrefs): Use it.
+
+2007-12-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Simplify the inspector.
+
+ * swank.lisp (inspect-object): Ignore the title value returned
+ from backends.
+
+ * slime.el (slime-open-inspector): Updated accordingly.
+
+2007-12-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Fix slime-list-thread selector.
+
+ * slime.el (slime-list-threads): Wait for the result before
+ continuing.
+
+2007-12-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-insert-result): Use slime-repl-emit-result
+ since handling of markers has changed.
+ (slime-repl-emit-result): New argument: bol.
+
+2007-12-02 Alan Caulkins <fatman(a)maxint.net>
+
+ Make it possible to close listening sockets.
+
+ * swank.lisp (stop-server, restart-server): New functions.
+ (*listener-sockets*): New variable.
+ (setup-server): Store open sockets in *listener-sockets*.
+
+2007-12-02 Helmut Eller <heller(a)common-lisp.net>
+
+ Add hook to customize the region used by C-c C-c.
+ Useful to recognize block declarations in CMUCL sources.
+
+ * slime.el (slime-region-for-defun-function): New variable.
+ (slime-region-for-defun-at-point): Use it.
+
+2007-11-30 Helmut Eller <heller(a)common-lisp.net>
+
+ Handle byte-functions without debug-info.
+
+ * swank-cmucl.lisp (byte-function-location): Return an error
+ if the component has no debug-info.
+
+2007-11-30 Helmut Eller <heller(a)common-lisp.net>
+
+ Disable the pretty-printer for backtraces.
+ Would be nice if we could print newlines in strings as \n.
+
+ * swank.lisp (*backtrace-printer-bindings*): New varaible.
+ (backtrace, frame-locals-for-emacs): Use it.
+
+2007-11-29 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (valid-function-name-p): Fixed wrt. setf functions.
+
+2007-11-29 Helmut Eller <heller(a)common-lisp.net>
+
+ Prettify package names for slime-repl-set-package.
+
+ * slime.el (slime-repl-set-package): slime-current-package may
+ have leading colons. Use slime-pretty-package-name to remove
+ them. Reported by Constantine Vetoshev.
+ (slime-pretty-current-package): New function.
+ (slime-set-package): Use it.
+
+2007-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ Drop remaining dependencies on nregex.
+
+ * swank-lispworks.lisp (unmangle-unfun): Use sys::setf-symbol-p
+ instead of regexp matching.
+
+ * swank-loader.lisp (*sysdep-files*): Don't include nregex.
+
+2007-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ Mirror *modules* in Emacs.
+
+ * slime.el (slime-lisp-modules): New connction variable.
+ (slime-set-connection-info): Load requested modules.
+ (slime-required-modules): New variable.
+ (slime-require, slime-load-contribs): New functions.
+
+ * swank.lisp (connection-info): Include *modules*.
+ (swank-require): Accept a list of modules as argument.
+
+2007-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (parse-package): The old version didn't pass the
+ test-suite. Now use the reader directly instead of emulating it
+ half-heartedly.
+
+ * slime.el (slime-search-buffer-package): Don't remove double
+ quotes or "#:", swank:parse-package takes care of that.
+
+2007-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (apropos-symbols): Use simple search instead of
+ regexps.
+ (make-apropos-matcher): Used to be make-regexp-matcher.
+
+ (*sldb-printer-bindings*): Set *print-right-margin* to
+ most-positive-fixnum. This prints each frame in the backtrace in a
+ single long line. But is suboptimal for other purposes, like
+ eval-in-frame.
+
+ (setup-server): Initialize multiprocessing here, so that is also
+ done for create-server.
+
+2007-11-23 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (swank-require): Fix typo (:key was used instead of
+ :test.) Reported by Stelian Ionescu.
+
+2007-11-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (swank-require): Don't search the file if the
+ module-name is present in *modules*. That should avoid problems if
+ swank is included in a core file and moved to a different
+ location. Reported by John Wiegley.
+
+2007-11-19 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-repl-mode-map, slime-repl-read-mode),
+ (slime-compiler-notes-mode-map, slime-xref-mode-map),
+ (sldb-mode-map, slime-connection-list-mode-map),
+ (slime-inspector-mode-map): Added bindings for [return] in
+ addition to (kbd "RET"). The reason is that pressing enter in X is
+ translated to (kbd "RET") only if no binding for [return] is
+ active; if [return] is bound to something, pressing enter is
+ translated to this key binding henceforth, as was explained to me
+ by Pierre Gaston, thanks! This can cause quite confusing behaviour
+ as Andreas Davour faced in his post <cs9k5ofqbt7.fsf(a)Psilocybe.Update.UU.SE>
+ to comp.lang.lisp.
+
+2007-11-06 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-events-buffer, slime-inspector-buffer): Disable
+ undo.
+
+2007-11-01 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ The inspector page layout has changed slightly. Before the header
+ looked like
+
+ A proper list.
+ [type: CONS]
+ -------------------
+
+ It now looks like
+
+ #<CONS {B3DBD39}>:
+ A proper list.
+ --------------------
+
+ Rationale is to have a "presentation link" to the currently
+ inspected object itself, to copy it down to the REPL via `M-RET'.
+ This is mostly useful when trying to get a value from the Slime
+ Debugger to the REPL, which you can do by inspecting the value
+ first by `i', and then using `M-RET' on the object representation
+ in the new header layout.
+
+ Such a "presentation link" existed already but was removed in
+ 2007-08-23. The old behaviour was to have the title ("A proper
+ list" in the above example) to contain the link. I decided to make
+ the link more explicit.
+
+ * swank.lisp (inspect-object): Now additionally returns a
+ string-representation of the object itself, and an inspector id
+ for it. Removed returning its type as this is implicit in the new
+ string representation.
+
+ * slime.el (slime-open-inspector): Adapted for new header layout.
+
+2007-10-22 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (read-softly-from-string, unintern-in-home-package):
+ Moved from `contrib/swank-arglist.lisp'.
+ (parse-package): Use them. (Removes FIXME about interning
+ symbols.) Also changed the logic somewhat to avoid passing :|| to
+ FIND-PACKAGE as ECL chokes on that.
+
+2007-10-22 Steve Smith <tarkasteve(a)gmail.com>
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Added
+ missing `load' argument to function definition on Corman Lisp /
+ ECL.
+
+2007-10-22 Mark Evenson <mark.evenson(a)gmx.at>
+
+ * swank-abcl.lisp (getpid): Implemented.
+
+2007-10-22 R. Matthew Emerson <rme(a)thoughtstuff.com>
+
+ * swank-openmcl.lisp (closure-closed-over-values): Use
+ CCL::NTH-IMMEDIATE instead of CCL::%SVREF. This makes it work on
+ x86-64 OpenMCL. (The %SVREF worked on PPC, but this will work on
+ both.)
+
+2007-09-27 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-filesystem-toplevel-directory): New function.
+ Windows doesn't have a filesystem that is as hierarchical as the
+ Unix' one. Reported by Carsten Blaauw and Stefan Kluehspies.
+ (slime-file-name-merge-source-root): Use it.
+ (slime-highlight-differences-in-dirname): Use it.
+
+2007-09-26 Utz-Uwe Haus <haus+slime(a)mail.math.uni-magdeburg.de>
+
+ * swank-allegro.lisp (fspec-definition-locations): Allow the
+ POSITION datum of :top-level-form fspecs to be missing. This
+ apparently helpful for Allegro CL 8.1.
+
+2007-09-21 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-length=, slime-length>): Restore support for
+ vectors, as `slime-length=' was already used with strings in
+ `slime-parse.el'. This broke extended arglist display.
+
+2007-09-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-setup): Call the respective init functions of
+ contribs.
+
+ * slime-autoloads.el (slime-setup-contribs): Ditto.
+
+2007-09-19 Helmut Eller <heller(a)common-lisp.net>
+
+ Simplify slime-compile-file.
+
+ * slime.el (slime-compile-file): Don't save window config.
+ (slime-curry, slime-rcurry): New functions.
+
+ * slime.el (slime-complete-symbol*-fancy): Move defcustom to
+ contrib/slime-c-p-c.el
+
+ * swank-version.el: Delete file. No longer used.
+
+ * bridge.el: Moved to contrib.
+
+ * tree-widget.el: File deleted. Only needed by contribs and is
+ distributed with Emacs 21.
+
+ * slime.el: Reorder some devfars and menus code so that the
+ compiler doesn't complain about free variables.
+
+ Fix apropos in Emacs 22.
+
+ * slime.el (slime-print-apropos): Add button props for Emacs 22.
+ (slime-call-describer): ARG is a marker in Emacs 22.
+
+ (def-slime-selector-method ?c): Wait until slime-list-threads
+ returns.
+
+ Remove define-slime-dialect.
+
+ * slime.el (define-slime-dialect): Deleted. Use
+ slime-lisp-implementations instead.
+
+ Introduce a slime-start-and-init function.
+
+ * slime.el (slime-start-and-init, slime-lisp-options): New
+ functions.
+ (slime-start-and-load): Use it.
+
+ Simplify slime-length=.
+
+ * slime.el (slime-length=, slime-length>): No need for vectors.
+
+ Remove explicit support for Scheme mode.
+
+ * slime.el (slime-scheme-mode-hook, slime-shared-lisp-mode-hook)
+ Deleted.
+ (slime-indentation-update-hooks): New hook.
+ (slime-handle-indentation-update): Use it.
+
+ Fix close-connection.
+
+ * swank.lisp (close-connection): Use *log-output* instead of
+ *debug-io* (which could be redirected to the to-be-closed
+ connection).
+
+2007-09-15 Helmut Eller <heller(a)common-lisp.net>
+
+ Let slime-setup load contribs.
+
+ * slime.el (slime-setup): Take a list of contribs to load as
+ argument.
+
+ * slime-autoloads.el (slime-setup): Ditto, but delay the actual
+ loading until slime is loaded.
+ (slime-setup-contribs): New function.
+
+2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-maybe-warn-for-different-source-root): Catch
+ returned NIL from `slime-file-name-merge-source-root' if the two
+ filenames don't share a common source root.
+ Reported by Frank Goenninger.
+
+2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-split-string): New semi-portability function.
+ The behaviour of `split-string' changed between Emacs21 and
+ Emacs22. Thanks to Christophe Rhodes for reporting this.
+ (slime-file-name-merge-source-root): Use `slime-split-string'.
+ (slime-highlight-differences-in-dirname): Likewise.
+
+2007-09-14 Helmut Eller <heller(a)common-lisp.net>
+
+ Some cleanups for the REPL.
+
+ * slime.el (slime-repl-write-string): Split it up into smaller
+ functions.
+ (slime-repl-emit, slime-repl-emit-result)
+ (slime-emit-string): New functions.
+
+ (slime-repl-save-history): Use prin1 instead of pp.
+
+ (repl-type-ahead): New test case.
+
+2007-09-12 Christophe Rhodes <csr21(a)cantab.net>
+
+ Make ASDF:LOAD-OP (and SBCL REQUIRE) happy with swank.asd
+
+ * swank.asd: Define and use a CL-SCRIPT-FILE class for loading as
+ source, even with ASDF:LOAD-OP.
+
+2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-loader.lisp: Aways compile-file `contrib/swank-asdf.lisp'
+ on SBCL. This fixes "Undefined function" style-warnings when using
+ `slime-asdf' in combination with SBCL. Reported by Cyrus Harmon.
+
+ * swank-sbcl.lisp: Explicitly require ASDF. (While this is not
+ strictly necessary, as it's implicitly loaded on requiring the
+ other modules, I think it's better to be explicit about it.)
+
+2007-09-10 Helmut Eller <heller(a)common-lisp.net>
+
+ Fix some bugs introduced while moving doc refs to contrib.
+
+ * swank-sbcl.lisp (condition-references): It's still needed.
+
+ * slime.el (sldb-dispatch-extras): Add missing quote.
+ (slime-sbcl-manual-root): Move definition to
+ contrib/slime-references.el.
+ (slime-cl-symbol-name, slime-cl-symbol-package): Move to
+ contrib/slime-parse.el.
+
+2007-09-10 Helmut Eller <heller(a)common-lisp.net>
+
+ Move SBCL doc references to contrib.
+
+ * slime.el (sldb-insert-condition): Merge REFERENCES and EXTRAS.
+ (sldb-extras-hooks, sldb-dispatch-extras): New hook.
+
+ * swank-backend.lisp (condition-references): Removed. Merged with
+ condition-extras.
+
+ * swank-sbcl.lisp (condition-references): Removed.
+ (condition-extras): Include references.
+ (externalize-reference): New function. Don't return plain
+ symbols.
+
+ * swank-allegro.lisp (condition-references): Removed.
+
+2007-09-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-cl-symbol-name, slime-cl-symbol-package):
+ Ressurected, as they're still used in this file.
+ Reported by Edward Cant.
+
+2007-09-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ When working on multiple source trees simultaneously, the way
+ `slime-edit-definition' (M-.) works can sometimes be confusing:
+
+ `M-.' visits locations that are present in the current Lisp image,
+ which works perfectly well as long as the image reflects the
+ source tree that one is currently looking at.
+
+ In the other case, however, one can easily end up visiting a file
+ in a different source root directory (the one corresponding to the
+ Lisp image), and is thus easily tricked to modify the wrong source
+ files---which can lead to quite some stressfull cursing.
+
+ If the variable `slime-warn-when-possibly-tricked-by-M-.' is
+ T (the default), a warning message is issued to raise the user's
+ attention whenever `M-.' is about opening a file in a different
+ source root that also exists in the source root directory of the
+ user's _current buffer_.
+
+ There's no guarantee that all possible cases are covered, but if
+ you encounter such a warning, it's a strong indication that you
+ should check twice before modifying.
+
+ * slime.el (slime-file-name-merge-source-root): New function.
+ (slime-highlight-differences-in-dirname): New function.
+ (slime-maybe-warn-for-different-source-root): New function.
+ (slime-warn-when-possibly-tricked-by-M-.): New variable (T by default.)
+ (slime-goto-location-buffer): Where appropriate, call
+ `slime-maybe-warn-for-different-source-root'
+
+2007-09-08 Stelian Ionescu <sionescu(a)common-lisp.net>
+
+ * slime.el (save-restriction-if-possible): Place macro definition
+ above use of the macro, to regain ability to byte-compile-file.
+
+2007-09-08 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Fix message displaying on XEmacs. Reported by Steven E. Harris,
+ and Ken Causey.
+
+ * slime.el (slime-display-message): Resurrect secondary
+ `buffer-name' argument which got lost in 2007-08-24.
+ (slime-format-display-message): Resurrect passing "*SLIME Note*"
+ as default buffer-name to `slime-display-message'.
+
+2007-09-08 Matt Pillsbury <mtbp(a)rci.rutgers.edu>
+
+ * swank-backend.lisp (definterface): Updated docstring.
+
+2007-09-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-write-string): Use case, not ecase, for
+ dispatching targets.Should fix XEmacs compatibility.
+ Reported by Steven E. Harris.
+
+2007-09-05 Didier Verna <didier(a)xemacs.org>
+
+ * slime.el (slime-filename-translations): Fix custom type.
+
+2007-09-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-toggle-trace-fdefinition): Fix typo. The
+ argument for interactive should be "P" not "p".
+
+2007-09-04 Mark Evenson <mark.evenson(a)gmx.at>
+
+ * swank-abcl.lisp: Call accessors of compiler-condition at load
+ time to work around some ABCL problems.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Move asdf support to contrib.
+
+ * swank-backend.lisp (operate-on-system): Moved to
+ swank-asdf.lisp. It wasn't specialized in any backend.
+
+ * swank.lisp (operate-on-system-for-emacs)
+ (list-all-systems-known-to-asdf, list-asdf-systems): Moved to
+ swank-asdf.lisp.
+
+ * slime.el: Move asdf commands to contrib slime-adsf.el.
+
+ * swank-loader.lisp: Load swank-asdf if ASDF is in
+ *FEATURES*. Also add the contrib source directory to
+ swank::*load-path*.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: Move tramp support to contrib.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Move startup animation to contrib.
+
+ * slime.el (slime-repl-banner-function): New hook.
+ (slime-repl-update-banner): Use it and reset markers after calling
+ it.
+ (slime-set-default-directory): Don't call slime-repl-update-banner
+ here.
+ (slime-repl-insert-prompt): Set slime-repl-input-end-mark to
+ point-max.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: Move inferior-slime-mode to contrib.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: Fix the test suite (except for SBCL).
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Simplify slime-process-available-input.
+
+ * slime.el (slime-process-available-input): We are called in a
+ process filter, i.e. at arbitrary times and in an aribtrary
+ buffer. So it doesn't make sense to save-and-restore the current
+ buffer here
+ (slime-eval-async): Instead, save and restore the buffer here.
+ (slime-net-read-or-lose): New.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Remove request-abort condition.
+
+ * swank-backend.lisp (request-abort): Removed
+ (abort-request): Removed. Replace all (3) uses with ERROR.
+ * swank.lisp (eval-for-emacs): No special case for request-abort.
+ * slime.el (slime-eval-async): Remove optional arg of :abort.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Rename slime-insert-possibly-as-rectangle to slime-insert-indented.
+
+ * slime.el (slime-insert-indented): Renamed. Update callers.
+
+2007-08-31 Helmut Eller <heller(a)common-lisp.net>
+
+ Move compound prefix completion and autodoc to contrib.
+
+ * swank.lisp (simple-completions): Rewritten for simplicity.
+ (operator-arglist): Rewritten for simplicity.
+
+ * slime.el (slime-complete-symbol-function): Make simple
+ completion the default.
+ (slime-echo-arglist-function, slime-echo-arglist): New hook.
+
+ Remove corresponding key bindigs.
+
+ * slime.el (slime-obsolete-commands): New table. Use it to bind
+ a command with an upgrade notice.
+
+2007-08-31 Andreas Fuchs <asf(a)boinkor.net>
+
+ * slime.el (slime-reindent-defun): Fixed when used in lisp file
+ buffers. (Similiar patch also provided by G�bor Melis; problem
+ also reported by Jeff Cunningham.)
+
+2007-08-31 Jon Allen Boone <ipmonger(a)delamancha.org>
+
+ * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as
+ the PPC-Darwin version. Changed to conditionalize on the
+ presence of darwin instead of ppc so that slime works with both
+ Darwin versions of CMUCL.
+
+2007-08-31 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-sexp-at-point): Explicitely set current syntax
+ table to operate in `lisp-mode-syntax-table' because
+ `thing-at-point' is used which depends on the syntax table. (E.g.
+ keywords like `:foo' aren't recognized as sexp otherwise.)
+
+ * slime.el (slime-parse-extended-operator/declare): Wrap regexp
+ stuff in `save-match-data'
+ (slime-internal-scratch-buffer): Removed again. Was only
+ introduced as a performance hack; but it turned out that the bad
+ performance was because of unneccessary recursive calls of
+ `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27
+ already.)
+ (slime-make-form-spec-from-string): Use `with-temp-buffer' instead
+ of `slime-internal-scratch-buffer'. Removed activation of
+ `lisp-mode' in the temporary buffer, because this made
+ `lisp-mode-hooks' run. This activated autodoc in the temp buffer,
+ although the temp buffer is used to compute an autodoc
+ itself (which resulted in some very mutual recursion which caused
+ the current arglist to be displayed again and again---as could
+ have been witnessed in `*Messages*'.) `Lisp-mode' was activated to
+ get the right syntax-table for `slime-sexp-at-point', but this one
+ sets the correct syntax-table itself now.
+
+2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Fix user input type-ahead again (this change from 2007-08-25 got
+ lost). Testcase: Type (dotimes (i 5) (format t "Number ~A~%"
+ i) (sleep 1)) and then type ahead while the command is executing
+ and output arrives.
+
+ * slime.el (slime-repl-insert-prompt): Don't go to point-max but
+ to slime-repl-input-start-mark if there is one.
+ (slime-repl-write-string): Insert a :repl-result before the
+ prompt, not at point-max. Update markers properly.
+
+2007-08-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp (safe-definition-finding): Remove whitespace
+ around error messages.
+ (trim-whitespace): New function.
+
+2007-08-28 Helmut Eller <heller(a)common-lisp.net>
+
+ Fix some output related bugs.
+
+ * swank.lisp (send-repl-results-to-emacs): Emit a fresh line.
+
+ * slime.el (slime-insert-transcript-delimiter): Use
+ insert-before-markers since slime-output-end is no longer left
+ inserting. Reported by Austin Haas <austin(a)pettomato.com>.
+
+2007-08-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-display-or-scroll-completions,
+ slime-scroll-completions): New functions. Factored out of
+ slime-expand-abbreviations-and-complete.
+
+2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-write-string): Handle arbitrary targets
+ using slime-output-target-marker.
+ (slime-last-output-target-id, slime-output-target-to-marker)
+ (slime-output-target-marker)
+ (slime-redirect-trace-output): Move back here from slime-presentations.el.
+
+2007-08-28 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (classify-symbol, symbol-classification->string):
+ Resurrected in swank.lisp. (I was bitten by cvs-pcl which
+ committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp'
+ where I already removed these functions from.)
+
+2007-08-28 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-make-form-spec-from-string): Elisp Hacking 101:
+ Don't use `beginning-of-buffer' and `end-of-buffer' in Elisp code.
+
+ * swank.lisp (read-form-spec): Unintern just newly interned
+ symbols when an reader error occurs.
+
+2007-08-28 Helmut Eller <heller(a)common-lisp.net>
+
+ Move presentations to contrib. Part II.
+
+ * swank.lisp (*listener-eval-function*): New variables.
+ (listener-eval): Use it
+ (repl-eval): Used to be listener-eval.
+ (*send-repl-results-function*): New variable.
+ (eval-region): Simplify.
+ (track-package, cat): New functions.
+ (slime-repl-clear-buffer-hook): New hook.
+ (slime-repl-clear-buffer): Use it.
+
+2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Remove the ID argument from :write-string protocol messages.
+ Everything, except for rigid-indentation tricks, can be achieved
+ by using :write-string in conjunction with :presentation-start and
+ :presentation-end.
+
+ * swank.lisp (present-in-emacs): Unused, removed.
+
+ * swank.lisp (make-output-function-for-target): Remove id argument
+ from :write-string.
+ (send-repl-results-to-emacs): Don't call
+ save-presented-object. Remove id argument from :write-string.
+
+ * slime.el (slime-dispatch-event): Change it here.
+ (slime-write-string, slime-repl-write-string): And here.
+
+2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-loader.lisp (*contribs*): Add swank-presentations.
+
+2007-08-27 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-make-extended-operator-parser/look-ahead): Move
+ to end of symbol at point.
+ (slime-make-form-spec-from-string): Fixes unexpected behaviour of
+ `save-excursion'.
+
+2007-08-27 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-sexp-at-point): Fixes a few edge cases were
+ Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example,
+ `foo(bar baz)' where point is at the ?\(.
+ (slime-internal-scratch-buffer): New. This variable holds an
+ internal scratch buffer that can be reused instead of having to
+ create a new temporary buffer again and again.
+ (slime-make-extended-operator-parser/look-ahead): Uses
+ `slime-make-form-spec-from-string' to parse nested expressions
+ properly.
+ (slime-nesting-until-point): Added docstring.
+ (slime-make-form-spec-from-string): Added new optional parameter
+ for stripping the operator off the passed string representation of
+ a form. Necessary to work in the context of
+ `slime-make-extended-operator-parser/look-ahead'. Added safety check
+ against a possible endless recursion.
+
+ * swank.lisp (parse-form-spec): Looses restriction for nesting.
+
+2007-08-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-eval-feature-conditional): Fix typo.
+ (slime-keywordify): Simplify.
+
+2007-08-27 Helmut Eller <heller(a)common-lisp.net>
+
+ Move presentations to contrib. Part I.
+
+ * slime.el (slime-event-hooks, slime-dispatch-event): New hook.
+ (slime-write-string-function, slime-write-string): New hook.
+ (slime-repl-return-hooks, slime-repl-return): New hook.
+ (slime-repl-current-input-hooks, slime-repl-current-input): New hook.
+ (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook.
+ (sldb-insert-locals, slime-inspector-insert-ispec)
+ (slime-last-expression): Don't use presentations.
+
+2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Reduces needless interning of symbols that was introduced by my
+ recent work on autodoc to a minimum. Also fixes this issue for
+ `slime-complete-form' which always interned symbols even before my
+ changes.
+
+ * slime.el (slime-sexp-at-point): If N is given, but there aren't
+ N sexps available at point, make it return a list of just as many
+ as there are.
+ (slime-make-form-spec-from-string): New. Creates a ``raw form
+ spec'' from a string that's suited for determining newly interned
+ symbols later in Swank.
+ (slime-parse-extended-operator/declare): Uses it.
+
+ * swank.lisp (parse-symbol): Returns internal knowledge, to
+ provide a means for callers to perform a sanity check.
+ (call-with-ignored-reader-errors): New. Abstracted out from
+ `read-incomplete-form-from-string.'
+
+ * swank.lisp (read-form-spec): New. Only READs elements of a form
+ spec if necessary. And if it does have to READ, it keeps track
+ of newly interned symbols which are returned as secondary
+ return value.
+ (parse-form-spec): Use it. Propagate newly interned symbols.
+ (parse-first-valid-form-spec): Likewise.
+ (arglist-for-echo-area, complete-form, completions-for-keyword):
+ Adapted to unintern the newly interned symbols.
+
+
+2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (current-slime-narrowing-configuration):
+ Renamed to `slime-current-narrowing-configuration'.
+ (set-slime-narrowing-configuration):
+ Renamed to `slime-set-narrowing-configuration'.
+ (current-slime-emacs-snapshot):
+ Renamed to `slime-current-emacs-snapshot'.
+ (current-slime-emacs-snapshot-fingerprint):
+ Renamed to `slime-current-emacs-snapshot-fingerprint'.
+ (set-slime-emacs-snapshot):
+ Renamed to `slime-set-emacs-snapshot'.
+
+2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (save-restriction-if-possible): Fixed another typo,
+ duh! Thanks again to Matthias Koeppe.
+
+2007-08-26 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-cl-symbol-name): Handle vertical bars (|)
+ (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'.
+
+2007-08-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Fix a bug where REPL results would sometimes be indented by a
+ random amount.
+
+ * slime.el (slime-insert-presentation): Make the
+ rectangle-ification of multi-line presentations, introduced
+ 2006-12-19, optional.
+ (slime-write-string): Use it here only for regular output, but not
+ for REPL results.
+ (sldb-insert-locals): Use it here.
+ (slime-inspector-insert-ispec): Use it here.
+
+2007-08-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Fix handling of user-input type-ahead in the REPL.
+ Reported by Madhu <enometh(a)meer.net> on 2007-04-24.
+
+ * slime.el (slime-write-string): Make sure text properties are
+ rear-nonsticky, so typed-ahead user input does not pick up the
+ text properties. Fix up some markers.
+ (slime-reset-repl-markers): Make the marker slime-output-end of
+ insertion type nil (no automatic advances on insertions).
+ (slime-with-output-end-mark): Update the location of
+ slime-output-end here manually.
+ (slime-repl-update-banner): Use insert-before-markers.
+
+2007-08-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ New command slime-redirect-trace-output creates a separate Emacs
+ buffer, where all subsequent trace output is sent.
+
+ * slime.el (slime-last-output-target-id): New variable.
+ (slime-output-target-to-marker): New variable.
+ (slime-output-target-marker): New function.
+ (slime-write-string): Handle general "target" arguments using
+ slime-output-target-marker.
+ (slime-redirect-trace-output): New command.
+ (slime-easy-menu): Add a menu item for it.
+
+ * slime.el (slime-mark-presentation-start)
+ (slime-mark-presentation-end): Make "target" argument optional.
+ Use slime-output-target-to-marker.
+
+ * swank.lisp (make-output-stream-for-target): New function,
+ factored out from open-streams.
+ (open-streams): Use it here.
+
+ * swank.lisp (connection): New slot "trace-output".
+ (call-with-redirected-io): Use it here.
+ (redirect-trace-output): New slimefun; set the slot to a new
+ target stream.
+
+2007-08-25 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (save-restriction-if-possible): Fixed typo in
+ macroexpansion. Thanks to Matthias Koeppe for reporting.
+
+2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-insert-arglist): Removed, superseded by
+ slime-complete-form since 2005-02-20.
+
+ * swank.lisp (arglist-for-insertion): Now unused, removed.
+
+2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Some fixes to the presentation-streams contrib.
+
+ * slime.el (slime-dispatch-event): Handle new optionals args of
+ messages :presentation-start and :presentation-end.
+
+ * slime.el (slime-mark-presentation-start)
+ (slime-mark-presentation-end): New arg "target"; record
+ presentation boundaries separately for REPL results and regular
+ process output. This fixes the presentation markup of REPL
+ results when the presentation-streams contrib is loaded.
+
+2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Make the fancy presentation-streams feature a contrib.
+ Previously, it was only available if "present.lisp" was loaded
+ manually. Now it can be loaded automatically using:
+
+ (add-hook 'slime-load-hook
+ (lambda () (require 'slime-presentation-streams)))
+
+ Note that the normal presentations that are created by REPL
+ results, the inspector, and the debugger are NOT dependent on this
+ code.
+
+ * present.lisp: Moved to contrib/swank-presentation-streams.lisp.
+ * swank-loader.lisp (*contribs*): Add swank-presentation-streams.
+
+2007-08-24 Helmut Eller <heller(a)common-lisp.net>
+
+ Move typeout frame to contrib.
+
+ * slime.el (slime-message-function, slime-background-message-function)
+ (slime-autodoc-message-function): New variables.
+ (slime-message, slime-background-message)
+ (slime-autodoc-message): Call the function in the respective
+ variable, so that the typeout window can be plugged in.
+
+2007-08-24 Helmut Eller <heller(a)common-lisp.net>
+
+ Move xref and class browser to contrib.
+
+ * slime.el (slime-browse-classes, slime-browse-xrefs): Gone. The
+ Common Lisp part is still there.
+
+2007-08-24 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.'
+ (slime-sexp-at-point): Return results as a list of strings, rather
+ than just one big string if called with arg > 1.
+ (slime-parse-extended-operator-name): Wrapping some movement code
+ in `ignore-errors'. Adapted to new return value of
+ `slime-enclosing-form-specs'. Minor cosmetic changes.
+ (slime-make-extended-operator-parser/look-ahead): Adapted to
+ changes of the ``raw form spec'' format; returns a form of
+ strings, instead of a string of a form.
+ (slime-parse-extended-operator/declare): Simplified. Adapted to
+ changes of the ``raw form spec'' format; passes decl-identifiers,
+ or typespec-operators respectively, along the decl/type-spec.
+ (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp
+ based approach.
+ (%slime-nesting-until-point): New helper for
+ `slime-parse-extended-operator/declare'.
+
+ * swank.lisp (parse-form-spec): Adapted to new ``raw form spec''
+ format. Updated format description in docstring accordingly. The
+ new format allows less interning of wrong symbols names comming
+ from Slime. Thanks to Matthias Koeppe for spotting this.
+
+2007-08-24 Helmut Eller <heller(a)common-lisp.net>
+
+ Move slime-highlight-edits-mode to contrib.
+
+2007-08-24 Helmut Eller <heller(a)common-lisp.net>
+
+ Move slime-scratch to contrib.
+
+ * slime.el (slime-scratch): Gone.
+
+2007-08-24 Helmut Eller <heller(a)common-lisp.net>
+
+ Various cleanups related to slime-insert-propertized.
+
+ * slime.el (slime-with-rigid-indentation): Fix evaluation order.
+ (slime-indent-rigidly): New.
+ (slime-insert-possibly-as-rectange): Don't set mark.
+ (slime-insert-propertized): Use plain insert instead of
+ slime-insert-possibly-as-rectange.
+
+2007-08-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (sbcl-inspector): Fix typo.
+
+2007-08-23 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Repair inspection of presentations.
+
+ * swank.lisp (inspect-presentation): New slimefun.
+ * slime.el (slime-inspect-presentation-at-mouse): Use it here.
+
+2007-08-23 Helmut Eller <heller(a)common-lisp.net>
+
+ Move Marco Baringer's inspector to contrib.
+
+ * swank.lisp (*default-inspector*): New variable. Set this
+ variable dispatch to different inspectors.
+ (inspect-object): Use it.
+
+ * swank-loader.lisp (*contribs*): Add 'swank-fancy-inspector.
+
+ * swank-backend.lisp (backend-inspector): New class. Introduce a
+ named class to give as another way to dispatch to backend methods.
+
+ * swank-cmucl.lisp: Use backend-inspector class.
+ * swank-sbcl.lisp: Use backend-inspector class.
+ * swank-clisp.lisp: Use backend-inspector class.
+ * swank-lispworks.lisp: Use backend-inspector class.
+ * swank-allegro.lisp: Use backend-inspector class.
+ * swank-openmcl.lisp: Use backend-inspector class.
+ * swank-abcl.lisp: Use backend-inspector class.
+ * swank-corman.lisp: Use backend-inspector class.
+ * swank-scl.lisp: Use backend-inspector class.
+
+2007-08-23 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Added arglist display for declaration specifiers and type
+ specifiers.
+
+ Examples:
+
+ `(declare (type' will display
+
+ (declare (type type-specifier &rest vars))
+
+ `(declare (type (float' will display
+
+ [Typespec] (float &optional lower-limit upper-limit)
+
+ `(declare (optimize' will display
+
+ (declare (optimize &any (safety 1) (space 1) (speed 1) ...))
+
+ &ANY is a new lambda keyword that is introduced for arglist
+ description purpose, and is very similiar to &KEY, but isn't based
+ upon plists; they're more based upon *FEATURES* lists. (See the
+ comment near the ARGLIST defstruct in `swank.lisp'.)
+
+ * slime.el:
+ (slime-to-feature-keyword): Renamed to `slime-keywordify'.
+ (slime-eval-feature-conditional): Adapted to use `slime-keywordify'.
+ (slime-ensure-list): New utility.
+ (slime-sexp-at-point): Now takes an argument that specify how many
+ sexps at point should be returned.
+ (slime-enclosing-operator-names): Renamed to
+ `slime-enclosing-form-specs'.
+ (slime-enclosing-form-specs): Returns a list of ``raw form specs''
+ instead of what was called ``extended operator names'' before, see
+ `swank::parse-form-spec' for more information. This is a
+ simplified superset. Additionally as tertiary return value return
+ a list of points to let the caller see where each form spec is
+ located. Adapted callers accordingly. Extended docstring.
+ (slime-parse-extended-operator-name): Adapted to changes in
+ `slime-enclosing-form-specs'. Now gets more context, and is such
+ more powerful. This was needed to allow parsing DECLARE forms.
+ (slime-make-extended-operator-parser/look-ahead): Because the
+ protocol for arglist display was simplified, it was possible to
+ replace the plethora of parsing function just by this one.
+ (slime-extended-operator-name-parser-alist): Use it. Also add
+ parser for DECLARE forms.
+ (slime-parse-extended-operator/declare): Responsible for parsing
+ DECLARE forms.
+ (%slime-in-mid-of-typespec-p): Helper function for
+ `slime-parse-extended-operator/declare'.
+ (slime-incomplete-form-at-point): New. Return the ``raw form
+ spec'' near point.
+ (slime-complete-form): Use `slime-incomplete-form-at-point'.
+
+ * swank.lisp: New Helper functions.
+ (length=, ensure-list, recursively-empty-p): New.
+ (maybecall, exactly-one-p): New.
+
+ * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form
+ specs'' from Slime.
+ (parse-form-spec): New. Takes a ``raw form spec'' and returns a
+ ``form spec'' for further processing in Swank. Docstring documents
+ these two terms.
+ (split-form-spec): New. Return relevant information from a form spec.
+ (parse-first-valid-form-spec): Replaces `find-valid-operator-name'.
+ (find-valid-operator-name): Removed.
+ (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'.
+
+ (defstruct arglist): Add `any-p' and `any-args' slots to contain
+ arguments belonging to the &ANY lambda keyword.
+ (print-arglist): Adapted to also print &ANY args.
+ (print-decoded-arglist-as-template): Likewise.
+ (decode-arglist): Adapted to also decode &ANY args.
+ (remove-actual-args): Adapted to also remove &ANY args.
+ (remove-&key-args): Split out from `remove-actual-args'.
+ (remove-&any-args): New. Removes already provided &ANY args.
+ (arglist-from-form-spec): New. Added detailed docstring.
+ (arglist-dispatch): Dispatching generic function for
+ `arglist-from-form-spec' that does all the work. Renamed from
+ prior `form-completion'.
+ (arglist-dispatch) Added methods for dealing with declaration and
+ type-specifiers.
+ (complete-form): Adapted to take ``raw form specs'' from Slime.
+ (completions-for-keyword): Likewise.
+ (format-arglist-for-echo-area): Removed. Not needed anymore.
+
+ * swank-backend.lisp (declaration-arglist): New generic
+ function. Returns the arglist for a given declaration
+ identifier. (Backends are supposed to specialize it if they can
+ provide additional information.)
+ (type-specifier-arglist): New generic function. Returns the
+ arglist for a given type-specifier operator. (Backends are
+ supposed to specialize it if they can provide additional
+ information.)
+ (*type-specifier-arglists*): New variable. Contains the arglists
+ for the type specifiers in Common Lisp.
+
+ * swank-sbcl.lisp: Now depends upon sb-cltl2.
+ (declaration-arglist 'optimize): Specialize the `optimize'
+ declaration identifier to pass it to
+ sb-cltl2:declaration-information.
+
+
+2007-08-23 Helmut Eller <heller(a)common-lisp.net>
+
+ Some inspector cleanups.
+
+ * slime.el (slime-inspect): Remove dwim stuff and drop keyword
+ args.
+ (slime-read-object): Killed.
+ (slime-open-inspector): Drop keyword args. Update callers
+ accodordingly, expect presentation related code. Presentations no
+ longer work in the inspector.
+
+ * swank.lisp (*inspector-dwim-lookup-hooks*)
+ (default-dwim-inspector-lookup-hook): Deleted.
+ (init-inspector): Sanitize arglist.
+ (inspect-object): Don't return an :id for *inspectee-parts*.
+
+ * swank-backend (type-for-emacs): Removed. No backend implemented
+ it.
+
+2007-08-23 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-fuzzy-upgrade-notice): New function. Bound to
+ the key where slime-fuzzy-complete-symbol used to be.
+
+2007-08-22 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-close-all-parens-in-sexp): Fix interplay with
+ `slime-close-parens-limit'. This should also affect
+ `slime-complete-form' (C-c C-s) in a positive way.
+
+2007-08-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * contrib: New directory. Move fuzzy completion code to that
+ directory.
+
+ * swank.lisp (swank-require): New function to load contrib code.
+ (*find-module*, module-filename, *load-path*, merged-directory)
+ (find-module, module-canditates): New. Pathname acrobatics for
+ swank-require.
+
+ * swank-loader.lisp: Compile (but don't load) contribs.
+ (*contribs*, contrib-source-files): New.
+
+2007-08-16 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-process-available-input): Correct yesterday's
+ change: the buffer a request was originally performed in doesn't
+ necessarily exist at this time anymore, so we check for buffer
+ liveness now.
+
+ The problem arised when quitting in SLDB which would cause Swank
+ to send a `:debug-return' message before the acknowledgement
+ message for `sldb-quit' is sent. So the acknowledgement is
+ received in a context where the sldb-buffer is closed already.
+
+2007-08-15 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-process-available-input): Make sure that the
+ event received from SWANK is processed in the context of the
+ original buffer the request of the response was performed in.
+ Previously, the clauses of `slime-rex' were processed in the
+ internal *cl-connection* buffer. And as a result the continuations
+ passed to `slime-eval' and `slime-eval-async' ditto.
+
+2007-08-15 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Make `M-.' work on definitions outside the current restriction.
+ `M-,' will also properly restore the narrowing as of before the
+ jump. Similiarly for quiting from the compilation notes buffer and
+ the Xref buffers.
+
+ * slime.el (slime-narrowing-configuration, slime-emacs-snapshot),
+ (current-slime-narrowing-configuration),
+ (set-slime-narrowing-configuration),
+ (current-slime-emacs-snapshot),
+ (set-slime-emacs-snapshot),
+ (current-slime-emacs-snapshot-fingerprint): New. Emacs' window
+ configurations do not restore narrowing, so introduce a
+ snapshot facility that contains the necessary information.
+
+ * slime.el: Various renaming and adaptions in the Slime temp
+ buffer, xref, goto-definition and compilation notes section to use
+ the newly introduced snapshots instead of mere window
+ configurations.
+
+ * slime.el: (slime-highlight-notes, slime-remove-old-overlays):
+ Still operate on whole buffer, but restore previous restriction if
+ there was any.
+ (slime-goto-location-position): Now widens the buffer to properly
+ jump to definitions outside of the current restriction.
+
+ * slime.el (slime-push-definition-stack),
+ (slime-pop-find-definition-stack): Now also stores information
+ about narrowing on the definition stack, in order to properly
+ restore narrowing on `M-,'.
+
+ * slime.el (def-slime-test narrowing): Test case for properly
+ dealing with narrowing.
+
+ * slime.el (slime-buffer-narrowed-p): New function, tests whether
+ the current buffer is narrowed or not.
+ (save-restriction-if-possibly): Like `save-restriction', but not
+ as strict---see doc string.
+
+ * slime.el (slime-length=): New function; semantically the same
+ as (= (length seq) n), but more efficiently implemented for lists.
+ Changed the above pattern into a call to SLIME-LENGTH= where
+ appropriate.
+
+2007-08-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (backtrace): Handle printer errors while printing a
+ frame. This makes debugging print-object methods with SLIME
+ easier. Reported by Utz-Uwe Haus.
+
+2007-08-02 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-kill-all-buffers): Now also kills all buffers
+ beginning with a `*SLIME' prefix (like, for instance, `*SLIME
+ Apropos*', or `*SLIME macroexpansion*'.)
+
+2007-06-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (def-slime-selector-method): Revert Marco's change from
+ 2007-05-23. BODY can return a buffer name, like "*slime-events*".
+ Handle that and never ignore invalid return values. Force BODY to
+ abort if there's no suitable buffer. Why would you want to switch
+ buffers if the desired buffer doesn't exist?
+
+2007-06-27 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Fixing `C-c M-q' at the REPL. Thanks to Andr� Thieme for pointing
+ out that it has been broken since several months.
+
+ * slime.el (slime-reindent-defun): Use functions
+ `slime-beginning-of-defun' and `slime-end-of-defun' that were
+ introduced in the last changeset.
+
+2007-06-16 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el: Pressing `C-M-a' (beginning-of-defun) in midst of the
+ last REPL prompt directs the cursor to the beginning of the
+ prompt. Pressing it again, would do nothing; now it moves the
+ cursor to the start of the previous prompt (as it's consistent
+ with the behaviour when the cursor was placed midst one of the old
+ prompts.)
+
+ Likewise for `C-M-e' (end-of-defun)
+
+ Additionally fixing `C-c C-s' (slime-complete-form) at the REPL.
+
+ (slime-keys): New bindings for `C-M-a' and `C-M-e' to
+ SLIME-BEGINNING-OF-DEFUN and SLIME-END-OF-DEFUN respectively.
+ (slime-keys): Making `C-c C-q' (slime-close-parens-at-point)
+ obsolete, as it didn't work correctly on the REPL.
+ (slime-repl-mode-map): Removed bindings for `C-M-a' and `C-M-e',
+ as they're now inherited from SLIME-KEYS.
+ (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Jump to
+ the previous (next) prompt if called twice in a row.
+
+ (slime-close-parens-at-point): Commented out.
+ (slime-close-all-sexp): Renamed to SLIME-CLOSE-ALL-PARENS-IN-SEXP.
+ (slime-close-all-parens-in-sexp): Modified to take
+ SLIME-CLOSE-PARENS-LIMIT into account.
+ (slime-complete-form): Use SLIME-CLOSE-ALL-PARENS-IN-SEXP.
+
+
+2007-05-24 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Fixed regression in completion: "swank[TAB]" would
+ previously be completed to "swank-backend:"; "get-internal[TAB]"
+ would be completed to "get-internal-r-time" (instead of simply
+ "get-internal-r"); and "custom:*comp[TAB]" would be completed to
+ "custom:*compiled-" on CLISP, even though there's a
+ "custom:*complile-".
+
+ Thanks to Ken Causey for helping me find the first two.
+
+ (completions): Revert changes from 2007-05-11.
+ (longest-compound-prefix): Fixed to properly generate a compound
+ _prefix_.
+
+2007-05-23 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (def-slime-selector-method): Allow the selector body to
+ not return a buffer. This means that, instead of being to forced
+ to signal an error when a choosen buffer can't be found (like
+ choosing d when there are no debugger buffers) can simply display
+ a message.
+
+ Fix handling of auto-flushing on sbcl:
+
+ * swank-sbcl.lisp (*auto-flush-interval*): New variable
+ controlling how often streams are flushed.
+ (*auto-flush-lock*): New lock guarding access to the shared
+ variable *auto-flush-streams*.
+ (make-stream-interactive): Wrapped access to *auto-flush-streams*
+ in a call-with-recursive-lock-held.
+ (flush-streams): Wrapped in call-with-recursive-lock-held.
+
+2007-05-17 Martin Simmons <martin(a)lispworks.com>
+
+ * swank-lispworks.lisp (lispworks-inspect): Fix hanging caused by
+ mapcan, i.e. nconc, on a constant list returned by
+ label-value-line.
+
+2007-05-17 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-complete-form): Only insert a closing
+ parenthesis if the form is not already closed. Reported by and
+ adapted from Mac Chan.
+
+2007-05-17 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Fixed bug in completion as previously "swank:[tab]"
+ would correctly list all the symbols in SWANK, but would
+ simultaneously append a spooky dash to the original
+ string ("swank:-").
+
+ (completions): Strip off the package identifier part, and only
+ compute the longest compound prefix for the actual symbol
+ identifiers.
+ (untokenize-symbol): New function. Inverse of TOKENIZE-SYMBOL.
+ (format-completion-result): Use UNTOKENIZE-SYMBOL.
+
+2007-05-17 Dustin Long <dlong(a)stevens.edu>
+
+ * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented
+ `slime-compile-defun' from actually compiling a function.
+
+2007-05-17 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-loader.lisp (*sysdep-files*): Load the auxiliary files
+ swank-source-*.lisp before swank-sbcl.lisp to avoid
+ undefined-function style warnings.
+
+2007-05-16 Takehiko Abe <keke(a)gol.com>
+
+ * swank.lisp (inspect-for-emacs file-stream, stream-error): Fixed
+ typo in keyword arg; it's `:refreshp', not `:refresh'.
+
+2007-05-14 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el: Fixed proper handling of the abortion of a
+ request. (For instance, when calling (SWANK::ABORT-REQUEST "FOO")
+ from the REPL.)
+
+ (sldb-quit): Updated the DESTRUCTURE-CASE clause for (:abort) to
+ take an argument.
+ (sldb-continue): Likewise.
+ (sldb-invoke-restart): Likewise.
+ (sldb-break-with-default-debugger): Likewise.
+ (sldb-return-from-frame): Likewise.
+ (sldb-restart-frame): Likewise.
+ (slime-repl-eval-string) Likewise.
+ (slime-repl-show-abort): Now also inserts the reason for the abort
+ into the REPL buffer.
+
+ * swank.lisp (eval-for-emacs): Remove code that would suggest that
+ it's possible to use the rex `(:abort ...)' with more than one
+ argument.
+
+2007-05-14 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Liberated from unnecessary style-warnings!
+
+ (eval-for-emacs): Don't use SLOT-VALUE on condition objects!
+ (inspect-bigger-piece-actions): Changed from DEFMETHOD to DEFUN.
+ (inspect-whole-thing-action): Likewise.
+ (inspect-show-more-action): Likewise.
+ (make-symbols-listing): Adds an explicit DEFGENERIC.
+ (menu-choices-for-presentation): Likewise.
+
+ (make-symbols-listing (eql :classification)): Use `(loop for k
+ being EACH hash-key ...)' rather than `(loop for k being THE
+ hash-key)', to omit the justified style-warning from CLISP.
+
+2007-05-14 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (package-names): Make sure to return a fresh list.
+ (fuzzy-find-matching-packages): Use PACKAGE-NAMES.
+ (list-all-package-names): Use PACKAGE-NAMES.
+
+2007-05-13 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-pretty-lambdas): Removed. If you really want
+ this, please use one of the external ressources that provide this;
+ for instance, `pretty-lambda.el', `pretty-greek.el', or even
+ `pretty-symbols.el'. For more information, please see
+
+ http://www.emacswiki.org/cgi-bin/wiki/PrettyLambda
+
+2007-05-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (fuzzy-find-matching-symbols): Modified to take
+ package nicknames into account. Previously, fuzzy completing on
+ nicknames did (except for some incidental cases) not work. Thanks
+ to Lu�s Oliveira and Attila Lendvai for pointing that out.
+
+2007-05-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Removed support for completing to the longest compound pre- and
+ suffix with the default completion method (C-c TAB, or just TAB on
+ the REPL), because it has been causing trouble all the time, but
+ didn't offer any real advantage besides niftiness. E.g.:
+
+ previous behaviour:
+
+ asdf:*com TAB => asdf:*compile-file--behaviour*
+
+ now simply:
+
+ asdf:*com TAB => asdf:*compile-file-
+
+ For discussing on this subject, please see the mail with
+ message-id <87y7l53lch.fsf(a)freebits.de> that was posted to
+ slime-devel 2007-04-06, or alternatively:
+
+ http://common-lisp.net/pipermail/slime-devel/2007-April/006087.html
+
+ * swank.lisp (make-compound-prefix-matcher): New function.
+ Abstracted from COMPOUND-PREFIX-MATCH.
+ (compound-prefix-match): Use MAKE-COMPOUND-PREFIX-MATCHER.
+ (compound-prefix-match/ci/underscores): Removed.
+
+ (longest-completion): Renamed to LONGEST-COMPOUND-PREFIX. Changed
+ to only return a compound prefix, instead of a concatenation of a
+ compound prefix and a compound suffix. Added an &optional
+ parameter to specify what delimeter the passed string is
+ compounded with.
+ (tokenize-completion): Takes additional parameter to specify the
+ delimeter for tokenization.
+ (longest-completion/underscores): Removed; not needed anymore.
+ (tokenize-completion/underscores): Likewise.
+ (untokenize-completion/underscores): Likewise.
+
+ (completions): Slight docstring modification, also added an
+ examplary use case; use LONGEST-COMPOUND-PREFIX instead of
+ LONGEST-COMPLETION.
+ (completions-for-character): Use LONGEST-COMPOUND-PREFIX, and
+ MAKE-COMPOUND-PREFIX-MATCHER.
+ (completions-for-keyword): Use LONGEST-COMPOUND-PREFIX.
+
+2007-05-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (apropos-symbols): Really use MAKE-REGEXP-MATCHER.
+
+2007-05-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Previously when using SLIME-APROPOS-PACKAGE, only
+ those symbols were considered whose home package matched the
+ given package; this would, however, prevent all those symbols from
+ being listed that are imported from another package, and then
+ exported again in the package they got imported into. (As an
+ example, SWANK:RESTART-FRAME is actually from SWANK-BACKEND.)
+
+ (apropos-matcher): Renamed to MAKE-REGEXP-MATCHER.
+ (make-regexp-matcher): Changed to only match for a given regexp.
+ (apropos-symbols): Use MAKE-REGEXP-MATCHER.
+
+2007-05-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el: Fix macroexpanding on things like ",(loop ...)".
+
+ (slime-sexp-at-point-for-macroexpansion): New function; like
+ SLIME-SEXP-AT-POINT-OR-ERROR, but fixes up some misbehaviour with
+ respect to macroexpansion.
+ (slime-eval-macroexpand, slime-eval-macroexpand-inplace): Use the
+ new function.
+
+2007-05-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el: Within the Slime Inspector, `S-Tab' will now also work
+ on X. Furthermore `Tab' and `S-Tab' will now correctly wrap
+ around the beginning and end of the buffer; priorly it'd hang on
+ the beginning with a message "Beginning of buffer", and would
+ require an additional `S-Tab'.
+
+ (slime-inspector-mode-map): Attached `[backtab]' to
+ SLIME-INSPECTOR-PREVIOUS-INSPECTABLE-OBJECT, as Emacs translates
+ `S-Tab' to `Backtab' on X.
+ (slime-find-inspectable-object): New function; finds next or
+ previous inspectable object.
+ (slime-inspector-next-inspectable-object): Mostly rewritten. Use
+ SLIME-FIND-INSPECTABLE-OBJECT to make the code clearer.
+
+2007-04-19 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-backend.lisp (label-value-line): Add :newline as &key
+ argument; if true (the default) inserts a newline.
+
+ * swank.lisp (inspect-for-emacs-list): Don't add a newline after
+ the last value of the list.
+
+2007-04-18 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (log-event): Setup the printer so that, no matter
+ what the global values of the *print-XYZ* variables, this function
+ works as expected.
+ (*debug-on-swank-error*): New variable.
+ (defpackage :swank): Export *debug-on-swank-error*.
+ (with-reader-error-handler): When *debug-on-swank-error* is
+ non-nil drop into a debugger.
+ (dispatch-loop): Idem.
+
+2007-04-17 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Instead of just having all the symbols of a package
+ listed alphabetically in the inspector page recently introduced
+ for that purpose, add a button to that page to group them by their
+ classification.
+
+ (%package-symbols-container): New slot GROUPING-KIND.
+ (%make-package-symbols-container): New function; wraps around
+ %%MAKE-PACKAGE-SYMBOLS-CONTAINER, which will actually create the
+ structure. We need this, to make GROUPING-KIND an entirely
+ internal affair.
+
+ (make-symbols-listing): New generic function to dispatch on
+ GROUPING-KIND.
+ (make-symbols-listing :symbol): Just the stuff that was priorly
+ wired into INSPECT-FOR-EMACS (%PACKAGE-SYMBOLS-CONTAINER).
+ (make-symbols-listing :classification): New; returns the passed
+ symbols grouped by their classification.
+ (inspect-for-emacs %package-symbols-container): Most code split
+ off into MAKE-SYMBOLS-LISTING.
+
+2007-04-17 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (swank-compiler): Fix the return value to always be a
+ list of two elements even if the abort restart is invoked which
+ originally just returned NIL. (Which wouldn't play with the recent
+ change to use DESTRUCTURING-BIND in SLIME-COMPILATION-FINISHED.)
+
+2007-04-17 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (inspect-for-emacs %package-symbols-container):
+ Revert Marco's change from 2007-04-08; he had the good idea of
+ adding a facility to jump to the relevant source line of a symbol,
+ but `M-.' is already bound to SLIME-FIND-DEFINITION in the
+ inspector, which is a nicer way of doing this alltogether.
+
+2007-04-16 Takehiko Abe <keke(a)gol.com>
+
+ * swank-openmcl.lisp (accept-connection, find-external-format):
+ utf-8 support.
+
+2007-04-16 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-with-xref-buffer): Added missing ,
+
+2007-04-16 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el: Pressing `q' in *compiler notes* after a `C-c C-k' or
+ `C-c M-k' would not probably restore the original window
+ configuration. Fix that.
+
+ (slime-get-temp-buffer-create): New &key arg WINDOW-CONFIGURATION.
+ (slime-with-xref-buffer): Likewise.
+
+ (slime-compilation-finished): New &optional arg WINDOW-CONFIG.
+ (slime-maybe-show-xrefs-for-notes): Likewise.
+ (slime-show-xrefs) Likewise.
+ (slime-maybe-list-compiler-notes): Likewise.
+ (slime-list-compiler-notes): Likewise.
+
+ (slime-compilation-finished-continuation): Renamed to
+ SLIME-MAKE-COMPILATION-FINISHED-CONTINUATION.
+
+ (slime-make-compilation-finished-continuation): Now takes two
+ args, the current buffer and optionally the current window config
+ to be restored.
+
+ (slime-compile-file): Save current window configuration before
+ popping up the REPL for compilation output, pass it down.
+ (slime-easy-menu): Add entry for SLIME-UNTRACE-ALL.
+
+2007-04-16 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (fuzzy-find-matching-packages): Fix a small typo that
+ prevented interpreting NIL as the argument TIME-LIMIT-IN-MEC to
+ mean an infinite time limit. This bug propagated up to explicit
+ calls to FUZZY-COMPLETIONS, like
+ (swank:fuzzy-completions "mvb" "COMMON-LISP") => (NIL, T)
+
+ (format-fuzzy-completions): Renamed to FORMAT-FUZZY-COMPLETION-SET
+
+ (format-fuzzy-completion-set): Accomodated to recent changes of
+ the return value of FUZZY-COMPLETIONS; changed the docstring to
+ make it explicit that this function is supposed to take the return
+ value of FUZZY-COMPLETION-SET.
+
+ * slime.el (slime-compilation-finished): Don't use
+ MULTIPLE-VALUE-BIND for list destructuring, only because multiple
+ values happen to be implemented via lists in elisp!
+ (slime-fuzzy-completions-mode): Added an detailed explanation to
+ the docstring of how Fuzzy Completion works and how it'ss supposed
+ to be worked with.
+ (slime-fuzzy-explanation): Shortened to reference to
+ SLIME-FUZZY-COMPLETIONS-MODE for help on fuzzy completion.
+ (slime-fuzzy-choices-buffer): Set BUFFER-QUIT-FUNCTION to
+ SLIME-FUZZY-ABORT to make it correctly exit fuzzy completion when
+ pressing `Esc Esc Esc' (`M-Esc Esc').
+
+2007-04-12 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank-sbcl.lisp (emacs-buffer-source-location): Add &allow-other-keys
+ to the descructuring of the source location plist in order to accept
+ :emacs-directory.
+
+2007-04-09 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (inspector-content-for-emacs): Look for refresh
+ keyword argument in :action links.
+ (inspect-whole-thing-action, inspect-show-more-action): Update for
+ new :action argument handling.
+ (inspect-for-emacs stream, inspect-for-emacs stream-error): Pass
+ :refresh nil on :action links.
+ (action-part-for-emacs): Set both lambda and refresh in the
+ *inspectee-actions* array.
+ (inspector-call-nth-action): *inspectee-actions* now holds both
+ the function and the boolean specifying whether to refresh or not.
+
+ * swank-backend.lisp (inspect-for-emacs): Docstring update.
+
+ * slime.el (slime-inspector-operate-on-point): Allow the action
+ calls to return nil.
+
+2007-04-08 Marco Baringer <mb(a)bese.it>
+
+ * .cvsignore: Added *.lx64fsl (openmcl on linux fasls).
+
+2007-04-08 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (inspect-for-emacs): Added 'jump to source' action
+ for symbols in the new package-symbol browser.
+
+2007-04-08 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Implemented a new special inspector page for
+ displaying internal (external, &c) symbols that display
+ classification flags additionally to each symbol, similiar to the
+ content of a *Fuzzy Completion* buffer. Furthermore, added the
+ possibility to display all symbols that are /present/ in a
+ package. Combined with cleanup of the code parts in question.
+
+ (symbol-status): New function. Returns the status of a symbol in a
+ given package (:internal, :external &c.)
+
+ (symbol-external-p): Adapted to use new function SYMBOL-STATUS.
+
+ (symbol-classification->string): New function. Converts a list of
+ classification flags into a concise string representation.
+
+ (%package-symbols-container): New struct. We need a unique type to
+ dispatch in INSPECT-FOR-EMACS for the new inspector page, use this
+ as a wrapper structure.
+
+ (inspect-for-emacs package): Reorganized to not cause too much eye
+ cancer; now with a saner maximum column width. Changed to make use
+ of new SYMBOL-STATUS, for code reuse. Also changed to make use of
+ new %PACKAGE-SYMBOLS-CONTAINER to let a new page pop up in Emacs
+ if the user wants to access the list of symbols of the package.
+ Added such a possibility to access all `present' symbols.
+
+ (inspect-for-emacs %package-symbols-container): New method.
+ Displays all symbols wrapped up in the container structure
+ combined with their classification flags as determined by
+ CLASSIFY-SYMBOL.
+
+2007-04-08 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ * swank-backend.lisp (compute-sane-restarts): New interface.
+ * swank-clisp.lisp: Fix tabs and trailing whitespace.
+ (compute-sane-restarts): Implement new interface.
+
+2007-04-08 Takehiko Abe <keke(a)gol.com>
+
+ * swank-openmcl.lisp (xref-locations):
+
+2007-04-08 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (fuzzy-completion-set): Use two check-type forms
+ instead of a place like (values limit time-limit-in-msec). While
+ sbcl seems to accept this form openmcl doesn't and it's not clear
+ from the spec that this is allowed.
+
+2007-04-07 Harald Hanche-Olsen <hanche(a)math.ntnu.no>
+
+ * slime.el (sldb-mode-map): Added key definition for follow-link.
+
+2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Making fuzzy completion regard the time limit
+ correctly. Also make it properly use microseconds as time
+ granularity and inform the Emacs side if the time limit has
+ exhausted. Additionally, over all minor and cosmetic changes:
+
+ (fuzzy-completions, fuzzy-completion-set): Returns now
+ additionally a flag indicating whether the time limit has
+ exhausted under the hood. Accomodated docstring accordingly.
+
+ (fuzzy-create-completion-set): Changed to correctly catch and
+ propagate the remaining time limit to the actual match functions,
+ and return once time limit has exhausted. Some aesthetical code
+ reorganization.
+
+ (get-real-time-in-msecs): New function.
+
+ (fuzzy-find-matching-symbols, fuzzy-find-matching-packages):
+ Correctly regard the time limit. Use new function
+ GET-REAL-TIME-IN-MSECS for that purpose. Return the remaining
+ time limit as second value.
+
+ * slime.el (slime-fuzzy-complete-symbol): Accomodated to deal with
+ the additionally returned flag of SWANK:FUZZY-COMPLETIONS. Pass
+ the flag by.
+ (slime-fuzzy-choices-buffer): Pass interruption flag by.
+ (slime-fuzzy-fill-completions-buffer): If time limit has exhausted
+ during completion retrieval, show an informational indication as
+ last entry in *Fuzzy Completion*.
+ (slime-fuzzy-last): New variable. To hold the last real completion
+ choice previous to the (possible) Time Limit Exhausted information.
+ (slime-fuzzy-next): Accomodated to not go beneath SLIME-FUZZY-LAST.
+
+2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp (tokenize-symbol, tokenize-symbol-thoroughly):
+ Previously these functions said a string representing a symbol is
+ internal exactly if it contained "::" as substring. Now they say
+ additionally so for symbols without any package identifier, as
+ they are internal to am implicit current package. (Otherwise
+ will break fuzzy completion.)
+
+ (tokenize-symbol): Added docstring.
+
+ * swank.lisp (format-completion-result): Fixed formation
+ for the case that PACKAGE-NAME is NIL but INTERNAL-P is T.
+
+2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Making fuzzy completion semantically right from a
+ user perspective. As an example on SBCL, "sb:with- C-c M-i" will
+ display all exported "with"-style macros in all sb-* packages from
+ now on. :)
+
+ (parse-completion-arguments): Replacing with a semantically-sound
+ implementation, as the previous one was a bit confused. Clarifying
+ docstring. Adding commentary table of various constellations of
+ returned values for thorough explanation.
+
+ (carefully-find-package): Removed. Obsolete by above change.
+
+ (defstruct fuzzy-matching): Introduced to make internally-used
+ datastructure explicit. Distinguishing ``completion chunks''
+ between those pertaining to the symbol itself and those to the
+ package identifier.
+
+ (convert-fuzzy-completion-result): Renamed to
+ FUZZY-CONVERT-MATCHING-FOR-EMACS.
+
+ (fuzzy-convert-matching-for-emacs): Accomodating for the new
+ datastructure. Only the chunks pertaining to the symbol itself are
+ fixed up positionally, the package-chunks are untouched.
+ Necessary for letting package identifiers be highlighted within
+ *Fuzzy Completions* in cases like "sb:with- C-c M-i."
+
+ (fuzzy-completion-set): Taking out most code to become new
+ function FUZZY-CREATE-COMPLETION-SET.
+
+ (fuzzy-create-completion-set): Doing all the hard work. Crux of
+ this changeset. so to speak. Largly rewritten to accomodate all
+ different cases of PARSE-COMPLETION-ARGUMENT.
+
+ (fuzzy-find-matching-symbols, fuzzy-find-matching-packages):
+ Accomodating to new datatstructure FUZZY-MATCHING. Adapting
+ docstring accordingly.
+
+ * swank-backend.lisp: Export WITH-STRUCT.
+
+ * swank.lisp (eval-for-emacs, fuzzy-completions):
+ Various trivia like fixing spelling and indentation.
+
+2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-fuzzy-highlight-current-completion): Fix
+ off-by-one error that causes the currently selected
+ completion in the *Fuzzy Completion* buffer be highlighted
+ one char too far.
+
+2007-04-06 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank.lisp: Cleanup of parts of the fuzzy completion code.
+ Additionally a couple of enhancements. As follows:
+
+ (fuzzy-completions, fuzzy-completion-selected): Minor
+ stylistic and clarifying modifications of the docstrings.
+
+ (fuzzy-find-matching-symbols): Huge code reorganization.
+ Organizing relevant code into local function TIME-EXHAUSTED-P,
+ renaming local function SYMBOL-MATCH to PERFORM-FUZZY-MATCH,
+ making previously required argument EXTERNAL to new &key
+ argument :EXTERNAL-ONLY, clarifying docstring.
+
+ (fuzzy-find-matching-packages): Making its return value
+ conformant to that of FUZZY-FIND-MATCHING-SYMBOLS, i.e.
+ instead of returning, among others, a package's name as
+ string, it now returns a symbol representing the package.
+ Accomodates the docstring accordingly.
+
+ (fuzzy-completion-set): Minor typographical fix in docstring.
+ Changing local function CONVERT to use MAP-INTO instead of
+ doing it essentially manually. Accomodating to changes of
+ FUZZY-FIND-MATCHING-SYMBOLS, resp. -PACKAGES.
+
+ (fuzzy-completion-set): Additional new feature:
+ The returned completions are sorted alphabetically by the
+ matched completion string before sorted by its score.
+ Affects especially the list of all possible completions when
+ the user hits fuzzy-completion on an empty string within Emacs;
+ also makes the potential limitness of the listed completions
+ clearer to the end user of SLIME.
+
+ (classify-symbol): New function. Returns a list with keywords
+ that classifies a given symbol. (E.g. :BOUNDP, :MACRO &c)
+ Supersedes parts of CONVERT-FUZZY-COMPLETION-RESULT,
+ implementing them in a more straightforward and proper way;
+ removes prior KLUDGE in that part of the original function.
+
+ (convert-fuzzy-completion-result): The above changes made
+ it possible to simplify this function drastically. Now uses
+ the newly introduced function CLASSIFY-SYMBOL.
+
+ * slime.el: Minor stylistic changes. Additionally:
+ (slime-fuzzy-insert-completion-choice):
+ (slime-fuzzy-fill-completions-buffer) : Adding use of the
+ :PACKAGE classification flag returned by SWANK:FUZZY-COMPLETIONS.
+ This flag is called "p".
+
+2007-04-06 Neil Van Dyke <neil(a)neilvandyke.org>
+
+ * slime.el (sldb-insert-frame): Added mouse-face to frame label
+ and expression in Backtrace.
+ (sldb-insert-frames): Added mouse-face to "--more--" label in
+ Backtrace.
+
+2007-04-06 Michael Weber <michaelw+slime(a)foldr.org>
+
+ * slime.el (slime-call-defun): insert the closing parenthesis for
+ the form.
+
+2007-04-06 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (package swank-mop): Added
+ slot-makunbound-using-class.
+
+2007-03-29 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank-sbcl.lisp (swank-compile-string): save the original
+ directory into the source plist as :emacs-directory.
+ (make-definition-source-location): use the :emacs-directory from
+ the source plist and guess-readtable-for-filename to determine the
+ correct readtable for string-compiled definitions.
+
+2007-03-29 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank.lisp (*macroexpand-printer-bindings*): add *print-lines*
+ to defaults (NIL).
+ (find-definitions-for-emacs): use unless instead of cond.
+
+2007-03-25 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * slime.el (with-selected-window): define for compatibility with
+ Emacs 21.
+
+2007-03-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (menu-choices-for-presentation): Offer a
+ "disassemble" menu item for functions.
+
+2007-03-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-read-port-and-connect): Fix race condition:
+ retry one more time if the port file is empty. Pop up the debugger
+ on other errors.
+ (slime-attempt-connection): Moved to toplevel.
+ (slime-timer-call): New. Used by slime-attempt-connection.
+ (slime-cancel-connect-retry-timer): New.
+ (slime-abort-connection): Use it.
+ (slime-repl-insert-prompt): Use insert-before-markers. This fixes
+ some redisplay problems, but I don't know why. Also: remove the
+ timer for async output.
+ (slime-repl-move-output-mark-before-prompt): Removed.
+ (slime-repl-save-merged-history): Use with-temp-message.
+ (slime-goto-location-buffer): Support Zip files.
+ (sldb-quit): Don't print "Evaluation aborted".
+
+2007-03-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-scratch-buffer): Respect the syntax text
+ properties of presentations.
+
+2007-03-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (lookup-presented-object): The presentation id of
+ frame locals now includes the thread id; ignore it for now.
+
+ * slime.el (slime-copy-presentation-at-mouse-to-point): Manually
+ invoke the after-change function, so that the presentation overlay
+ is created even if we paste to non-REPL buffers.
+ (slime-menu-choices-for-presentation): Evaluate
+ menu-choices-for-presentation-id in the right buffer, thus in the
+ right Lisp thread. Reported by Attila Lendvai.
+ (slime-menu-choices-for-presentation): Show the id of the presentation.
+ (sldb-insert-locals): Include the thread id in the presentation id.
+
+2007-03-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-eval-string, slime-repl-insert-result):
+ Support the presentation-less old protocol.
+ (slime-goto-location-position): Use column number if available.
+
+2007-03-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (completion-output-symbol-converter): Fix completion
+ for mixed-case symbols that need escaping in readtable-case
+ :upcase or :downcase.
+
+ * slime.el (slime-copy-presentation-at-mouse-to-point)
+ (slime-copy-presentation-at-mouse-to-kill-ring): New commands.
+ (slime-menu-choices-for-presentation): Change interface. New
+ menu options, Copy to kill-ring, Copy to point.
+ (slime-presentation-menu): Change call to
+ slime-menu-choices-for-presentation.
+
+2007-03-20 Takehiko Abe <keke(a)gol.com>
+
+ * swank-openmcl.lisp (hash-table-weakness): fix typo
+
+2007-03-14 Christophe Rhodes <csr21(a)cantab.net>
+
+ * slime.el (slime-search-suppressed-forms): handle multiple
+ conditionals on the same line.
+
+2007-02-26 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank.lisp (inspect-for-emacs): Add support for inspecting
+ non-decodable float entities like NaNs and infinities.
+
+2007-02-25 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-backend.lisp (inspect-for-emacs): Remove reference to
+ inexistent argument from docstring.
+
+2007-02-25 Harald Hanche-Olsen <hanche(a)math.ntnu.no>
+
+ * slime.el (slime-init-keymaps): Use vectors when defining keys,
+ because e.g. (define-key (string ?\C-c) ...) doesn't work in the
+ emacs-unicode-2 branch. Some strings are still there.
+
+2007-02-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-delete-swank-port-file): Don't use
+ display-warning; that's not available everywhere.
+ (slime-repl-update-banner): Insert the date only if the buffer is
+ empty.
+ (slime-list-compiler-notes): Fetch the notes only if called
+ interactively.
+ (slime-set-query-on-exit-flag): New function, to avoid compiler
+ warnings about obsolete function process-kill-without-query.
+ (slime-defun-if-undefined): Perform the test at runtime not at
+ compile time. Reported by Lennart Staflin.
+
+ * swank.lisp (guess-package): Renamed from
+ guess-package-from-string.
+ (set-package): Use it.
+
+2007-02-22 Juho Snellman <jsnell(a)iki.fi>
+
+ * slime.el (slime-start-lisp): Don't cd if no directory was specified.
+ (slime-maybe-start-lisp): Pass directory argument to slime-start-lisp
+ also in other cond branch.
+ (slime-restart-sentinel): Pass a NIL directory to slime-start-lisp.
+
+2007-02-21 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-start): Added :directory argument and pass it to
+ slime-maybe-start-lisp.
+ (slime-maybe-start-lisp): Added directory argument and pass it to
+ slime-start-lisp (but not slime-reinitialize-inferior-lisp-p)
+ (slime-start-lisp): Added directory argument. Used to set buffer's
+ directory before starting the inferior lisp.
+
+2007-02-17 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-find-tag-if-tags-table-visited): New function.
+ (slime-edit-definition-fallback-function): Offer it as a value
+ for customization.
+
+2007-02-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (sldb-insert-locals): Repair presentation markup of
+ frame locals.
+
+2007-02-04 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt>
+
+ * swank-lispworks.lisp (dspec-file-position): Bind
+ *compile-file-pathname*, *compile-file-truename*, *load-pathname*
+ and *load-truename* in dspec-file-position.
+
+2007-02-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-write-string): When writing a :repl-result,
+ update the slime-output-end marker for the purpose of asynchronous
+ output (when *use-dedicated-output-stream* is true).
+ Reported by Madhu <enometh(a)meer.net>.
+
+2007-02-03 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-delete-swank-port-file): Fix typo in
+ warning message.
+
+2007-02-02 Marco Baringer <mb(a)bese.it>
+
+ Warn, as opposed to bailing out with an error, when deleting the
+ port file fails. Patch by: Samium Gromoff
+ <_deepfire(a)feelingofgreen.ru>
+
+ * slime.el (slime-delete-swank-port-file): New function.
+ (slime-inferior-connect): Use slime-delete-swank-port-file.
+ (slime-read-port-and-connect): Use slime-delete-swank-port-file.
+
+2007-01-31 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-repl-update-banner): Restore animation.
+ (slime-startup-animation): restore.
+
+2007-01-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-complete-symbol-function): Restore old default.
+ (set-keymap-parents): Deleted.
+ (slime-startup-animation): Deleted.
+ (slime-read-from-minibuffer): Don't use defun*.
+ (slime-repl-terminate-history-search): New.
+ (slime-repl-next-matching-input): Use it.
+
+ * slime-autoloads.el: New file.
+
+2007-01-29 Sean O'Rourke <sorourke(a)cs.ucsd.edu>
+
+ * slime.el (slime-start): Continue even if the user, after
+ prompting, didn't recompile the stale .elc file.
+ (slime-urge-bytecode-recompile) [xemacs]: Abort immediately if the
+ user doesn't want to continue.
+ (slime-recompile-bytecode): Don't use byte-compile-warning-types;
+ it may not exist in XEmacs.
+
+2007-01-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (sldb-recenter-region): Use count-screen-lines instead
+ of count-lines.
+
+ * swank.lisp (unparse-name): New function.
+ (list-all-package-names): Use it. This fixes a bug related to
+ readtable-case and makes package name completions look prettier.
+ Suggested by Harald Hanche-Olsen <hanche(a)math.ntnu.no>.
+
+2007-01-24 Bill Clementson <billclem(a)gmail.com>
+
+ * slime.el (slime-call-defun): Put the docstring before
+ the (interactive) form so that "C-h f slime-call-defun" will
+ return it.
+
+ * slime.el (slime-scratch-mode-map): Changed parent keymap to
+ lisp-mode-map to prevent unnecessary duplication of slime-mode-map
+ bindings and so that lisp-mode-map key bindings are present in the
+ slime scratch buffer. Change identified by Ariel Badichi.
+
+2007-01-20 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime): Use COMMAND and CODING-SYSTEM parameters
+ Previously they were ignored.
+
+2007-01-17 Christian Lynbech <christian.lynbech(a)ericsson.com>
+
+ * slime.el (slime-init-command): Use expanded files when writing
+ the LOAD form for swank.
+
+2007-01-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: Cleanups for the repl history code.
+ (slime-repl-mode-map): Don't shadow M-C-d.
+ (slime-repl-history-replace): Simplified.
+ (slime-repl-history-search-in-progress-p): New.
+ (slime-repl-position-in-history): If there's no match return
+ out-of-bound positions instead of nil.
+ (slime-repl-add-to-input-history): Never modify the argument.
+ (slime-repl-previous-input): Renamed from
+ slime-repl-previous-input-starting-with-current-input.
+ (slime-repl-next-input): Renamed from
+ slime-repl-next-input-starting-with-current-input
+ (slime-repl-forward-input): Renamed from slime-repl-next-input.
+ (slime-repl-backward-input): Renamed from
+ slime-repl-previous-input.
+ (slime-repl-history-pattern): Renamed from
+ slime-repl-matching-input-regexp.
+ (slime-repl-delete-from-input-history): Simplified.
+
+ (slime-repl-history-map)
+ (slime-repl-history-navigation-neutral-commands)
+ (slime-repl-jump-to-history-item)
+ (slime-repl-previous-or-next-input)
+ (slime-repl-starting-with-current-input-regexp)
+ (slime-repl-continue-search-with-last-pattern)
+ (slime-repl-previous-or-next-matching-input): Deleted.
+
+ (sldb-list-locals, sldb-list-catch-tags): Deleted. Aren't of much
+ use anymore.
+
+2007-01-12 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-clisp.lisp: Better classification on frames on the stack.
+ Make variables in eval frames accessible to the debugger.
+ (frame-type, *frame-prefixes*, frame-to-string, is-prefix-p)
+ (frame-string-type, boring-frame-p): New.
+ (%frame-count-vars, %frame-var-name, %frame-var-value)
+ (frame-venv, next-venv, venv-ref, %parse-stack-values): Replaces
+ old frame-do-venv.
+ (extract-frame-line, extract-function-name, split-frame-string)
+ (string-match): New code to print frames.
+ (frame-locals, frame-var-value): Use the new stuff.
+
+ (inspect-for-emacs): Fix various bugs.
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Don't wrap
+ everything in a compilation unit. If we abort on load errors and
+ it is confusing to see compiler warnings after the abort message.
+ (handle-loadtime-error): CLISP's format implements ~< differently
+ as everybody else, so use a explicit pprint-logical-block instead.
+
+ * swank.lisp (list-all-systems-in-central-registry): Don't
+ reference asdf directly, that leads to read errors in some
+ systems.
+
+2007-01-12 Juho Snellman <jsnell(a)iki.fi>
+
+ * slime.el (slime-read-expression-map): Switch the slime-mode-map
+ and minibuffer-local-map back the way they were. The previous change
+ was made due to a misunderstanding, caused by a keybinding for
+ [(return)] apparently being more specific than one for (kbd "RET"),
+ even when the former is in a parent keymap and the latter in the
+ child.
+
+2007-01-12 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (handle-request): Use 'abort as restart name, but
+ bind *sldb-quit-restart* to the restart returned by find-restart.
+ Also use a slighly friendlier message, because newbies seem to
+ invoke the ABORT restart instead of pressing q in the debugger.
+
+2007-01-12 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-find-asd): Remove file extension.
+
+ (slime-read-system-name): Use SWANK:LIST-ASDF-SYSTEMS.
+
+ * swank.lisp (list-all-systems-in-central-registry): Use only
+ pathname name.
+
+ (list-all-systems-known-to-asdf): New function.
+
+ (list-asdf-systems): New function.
+
+2007-01-12 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-keys): Remove binding of M-*, restore binding of
+ M-,.
+
+2007-01-11 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-repl-test-system, slime-repl-test/force-system):
+ New REPL shortcuts. Patch by Kevin Rosenberg
+ <kevin(a)rosenberg.net>.
+
+2007-01-11 Juho Snellman <jsnell(a)iki.fi>
+
+ * slime.el (slime-read-expression-map): restore tab completion in
+ the minibuffer. Switch the slime-mode-map and minibuffer-local-map
+ around, so that the minibuffer binding for return takes precedence
+ over the slime-mode one.
+
+2007-01-11 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (inspect-for-emacs integer): Don't die if the integer
+ can't be expressed as a float. Patch by Ariel Badichi
+ <abadichi(a)bezeqint.net>.
+
+ * slime.el (slime-keys): Removed binding of M-,
+
+2007-01-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: Some cleanups for the debugger code: add some outline
+ sections and docstrings.
+
+ (sldb-setup): Always display the beginning of the condition
+ text. Previously, we always showed the beginning of the backtrace.
+
+ (sldb-prune-initial-frames): Do what the docstring says. Reverted
+ to Luke's version.
+
+ (sldb-dispatch-extras): Fix typo.
+
+ (sldb-insert-restarts, sldb-insert-frames)
+ (sldb-insert-frame, sldb-fetch-more-frames)
+ (sldb-toggle-details, sldb-show-frame-details)
+ (sldb-insert-locals): Simplified.
+ (sldb-frame-details): New.
+
+ (slime-save-coordinates, slime-coordinates)
+ (slime-restore-coordinate, slime-count-lines): New macro and its
+ helpers.
+ (sldb-recenter-region): Renamed from slime-maybe-recenter-region.
+
+ (sldb-enable-styled-backtrace, sldb-show-catch-tags)
+ (sldb-highlight): Deleted. Seem to be obsolete.
+ (sldb-add-face): Removed, because it is now the same as
+ slime-add-face.
+
+ (sldb-help-summary): Deleted. The docstring for sldb-mode is
+ already pretty terse.
+ (define-sldb-face): Renamed from def-sldb-face.
+
+ * swank-sbcl.lisp, swank-cmucl.lisp (condition-extras): Fix typo
+
+2007-01-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*sldb-printer-bindings*): Add *print-right-margin*.
+ (debug-in-emacs): Bind *sldb-printer-bindings* here ...
+ (backtrace, debugger-info-for-emacs, frame-locals-for-emacs):
+ ... and remove redundant bindings here.
+
+2007-01-10 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el: FIX: set-keymap-parents for GNU Emacs was bogus, fixed
+ by Ariel Badichi.
+
+2007-01-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-merge-histories): Use (setf (gethash ...)
+ instead of puthash, for Emacs 20.
+
+2007-01-09 Juho Snellman <jsnell(a)iki.fi>
+
+ SBCL 1.0.1.15 supports restart-frame natively, and uses a different
+ debug catch tag interface than earlier versions.
+
+ * swank-sbcl (sbcl-with-restart-frame): New function, detects SBCL
+ 1.0.1.15 or later.
+ (return-from-frame): Another version for 1.0.1.15, using
+ sb-debug:unwind-to-frame-and-call
+ (restart-frame): Another version for 1.0.1.15, using
+ sb-debug:unwind-to-frame-and-call
+
+2007-01-07 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (open-streams): Don't pass nil to make-fn-streams;
+ use a dummy function as workaround. Both arguments must be
+ functions and CMUCL checks the types.
+
+2007-01-06 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el: Added set-keymap-parents when not available (GNU
+ Emacs). Result: slime bindings while reading expressions from the
+ minibuffer.
+
+ * slime.el, swank.lisp: FIX: slime-insert-possibly-as-rectange and
+ sldb stuff on newer emacsen
+
+2007-01-04 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el: Added slime-insert-possibly-as-rectangle and use it
+ when inserting things here and there. The effect of this is that
+ multi-line strings coming from swank (e.g. stuff in sldb) are
+ inserted with insert-rectangle, so they are properly indented.
+
+ * swank.lisp: FIX: sort is destructive, call copy-seq at a few
+ places. FIX: bind *sldb-printer-bindings* also in
+ frame-locals-for-emacs.
+
+2007-01-03 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * swank.lisp: FIX: drop extra "Slots: " from standard-object's
+ inspector presentation
+
+ * swank.lisp: FIX: keyword symbols keep their : when travelling
+ from swank to slime
+
+ * slime.el: FIX: older Emacsen have no line-number-at-pos.
+
+ * slime.el: Convert some minibuffer reading defun's to defun* and
+ use keywords. Support extra arguments.
+
+ * slime.el: Use set-parent-keymaps when available (xemacs only for
+ now) when setting up slime-read-expression-map. The effect of this
+ is that the minibuffer will have all the slime-mode-map keys where
+ minibuffer-local-map is not overriding.
+
+ * slime.el, swank.lisp: Handle better the case when swank can not
+ read anything from the string sent to be inspected. Only bring up
+ the debugger when the inspect command is prefixed.
+
+2006-12-31 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Restore the nested-presentations feature.
+
+ * present.lisp (slime-stream-p): Allow sending presentations to
+ the repl-results stream.
+ (make-presentations-result): Removed.
+ (send-repl-results-to-emacs): New.
+
+ * swank.lisp (connection): New slot repl-results (a stream).
+ (make-output-function-for-target): New.
+ (open-streams): Use it here to also create a stream for REPL results.
+ (initialize-streams-for-connection): Store the stream.
+
+2006-12-29 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-find-asd, slime-read-system-name): Only offer
+ initial input if system is really in central registry.
+
+2006-12-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Simplify the REPL-results protocol. The results are now printed
+ using special :WRITE-STRING events from the Lisp side.
+
+ * slime.el (slime-repl-insert-prompt): Don't insert a result, only
+ the prompt.
+ (slime-repl-insert-result): Removed.
+ (slime-repl-eval-string, slime-repl-show-abort)
+ (slime-repl-set-package, slime-output-buffer)
+ (slime-repl-update-banner): Change all callers.
+ (slime-dispatch-event): Event :WRITE-STRING gets an
+ optional argument TARGET, which controls where the string is
+ inserted.
+ (slime-write-string): Handle targets NIL (regular process output)
+ and :REPL-RESULT.
+
+ * swank.lisp (make-presentations-result): Removed.
+ (send-repl-results-to-emacs): New function, sends :WRITE-STRING events.
+ (listener-eval): Use it here instead of make-presentations-result.
+
+2006-12-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Performance improvement for slime-autodoc-mode, in particular when
+ there are REPL results that are long lists.
+
+ * slime.el (slime-repl-mode-beginning-of-defun)
+ (slime-repl-mode-end-of-defun): New.
+ (slime-repl-mode): Use them as beginning-of-defun-function and
+ end-of-defun-function.
+ (slime-enclosing-operator-names): Bind
+ parse-sexp-lookup-properties to nil, don't parse more than 20000
+ characters before point, don't determine exact argument positions
+ larger than 64. Byte-compile this function.
+
+2006-12-24 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el, swank.lisp: Added customizable dwim lookup hook
+ support for inspect
+
+ * doc/slime.texi: Small doc fixes by Alfredo Beaumont
+
+ * swank.lisp: Change the order to [set value] [make unbound]. Sort
+ slot names in the inspector
+
+2006-12-23 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-clisp.lisp (make-weak-key-hash-table)
+ (make-weak-value-hash-table): Implement for CLISP, so that the
+ REPL results history does not cause "memory leaks".
+
+ * slime.el (slime-inspect): Add a dwim-mode keyword argument, move
+ all input handling into the interactive spec. Restore the
+ behavior of slime-inspect when point is within a presentation (no
+ prompting, no DWIM).
+ (slime-inspect-presentation-at-mouse): Don't do DWIM here, so the
+ presentation-retrieval expression does not end up on the inspector
+ stack.
+ (slime-inspector-position): New.
+ (slime-inspector-operate-on-point, slime-inspector-reinspect): Use
+ it here to make it work on GNU Emacs too.
+ (slime-open-inspector): Fix row-col addressing at end of buffer.
+
+2006-12-20 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el: FIX: inspecting presentations from the right click
+ menu broke in the inspect refactor
+
+ * slime.el: FIX: slime-fuzzy-target-buffer-completions-mode's
+ keymap must always precede other keymaps
+
+ * slime.el, swank.lisp: Extend :write-string with and &optional
+ presentation id and use this in present-in-emacs
+
+ * swank.lisp: Added present-in-emacs that prints a presentation of
+ the given object in the repl
+
+ * swank.lisp: Return the inspected object when inspecting from the
+ lisp side.
+
+ * swank.lisp: Turn off right margin for restart printing, too
+
+2006-12-19 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * HACKING: Added useful init.el piece into HACKING about
+ update-change-log
+
+ * swank.lisp: In all-slots-for-inspector pad slot names to be
+ equal length, so the result is more readable
+
+ * slime.el: Fix slime-insert-presentation to handle multi-line
+ presentations better (use insert-rectangle)
+
+ * swank.lisp: Properly bind *sldb-printer-bindings* and turn off
+ right margin while printing stuff in sldb
+
+ * slime.el: Smarten up the sldb heuristic that drops swank frames
+
+ * swank-allegro.lisp, swank-backend.lisp, swank-openmcl.lisp,
+ swank-sbcl.lisp, swank.lisp: Added hash-table-weakness and use it
+ in hash-table-inspecting
+
+ * swank.lisp: Hashtable inspecting: added [clear hashtable]
+ and [remove entry] actions
+
+ * slime.el, swank.lisp: FIX dwim inspecting to handle (setf
+ some-fun) functions, too
+
+ * slime.el: FIX: slime-sexp-at-point for foo::|bar::baz|
+
+ * slime.el: FIX: Properly keep track of slime-buffer-package in
+ the inspector
+
+ * swank.lisp: Small: get rid of notes and warnings
+
+ * slime.el, swank.lisp: Added dwim-mode to slime-inspect that
+ tries to be smart unless prefixed
+
+ * slime.el: Make slime-fuzzy-complete-symbol the default in the
+ belife that it's better for new users
+
+ * swank.lisp: Add (expt 1.2 length) higher scores for longer
+ matches in fuzzy completion. A good example: puts "make-instance"
+ before "make-string-input-stream" while completing "make-ins"
+
+ * slime.el: Set slime-fuzzy-completion-in-place enabled by default
+
+ * slime.el: Added (cons row col) addressing to
+ slime-open-inspector, use in slime-inspector-operate-on-point
+
+ * slime.el: FIX: operate the inspector in the debug thread when
+ started from sldb
+
+ * slime.el: Convert some inspector defuns to defun* and use
+ keywords. Other minor cleanups.
+
+2006-12-18 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-region-for-defun-at-point): end-of-defun and
+ beginning-of-defun modify match-data, added a save-match-data to
+ prevent this from affecting callers of
+ slime-region-for-defun-at-point.
+
+2006-12-15 Edi Weitz <edi(a)agharta.de>
+
+ * swank-lispworks.lisp (make-weak-key-hash-table): Weak hash
+ tables for Lispworks.
+ (make-weak-value-hash-table): Ditto.
+
+2006-12-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*sldb-printer-bindings*): *PRINT-LINES* is in
+ effect only if *PRINT-PRETTY* is non-NIL, so it better to enable
+ the pretty printer. Suggested by Madhu <enometh(a)meer.net>.
+
+ * slime.el (slime-expand-abbreviations-and-complete): Emacs
+ `choose-completion' (choosing a completion from the *Completions*
+ buffer) always replaces text upto (point). So the code which
+ figures out an `unambiguous-completion-length' and places the
+ point there in `slime-expand-abbreviations-and-complete' causes
+ problems: the replacement text gets garbled. Get rid of the bogus
+ `unambiguous-completion-length'. Patch by Madhu <enometh(a)meer.net>
+
+ * swank-cmucl.lisp (remove-gc-hooks): The variables
+ EXT:*GC-NOTIFY-AFTER* and EXT:*NOTIFY-BEFORE* should hold
+ functions and should be NIL. This affects the function
+ REMOVE-GC-HOOKS in swank-cmucl.lisp which sets them to
+ NIL, (should one happen to use it). Set them back to the original
+ parameters. Patch by Madhu <enometh(a)meer.net>
+
+ * slime.el (slime-repl-output-mouseover-face): Fix a pair of extra
+ parens. Patch by Madhu <enometh(a)meer.net>
+
+2006-12-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-search-buffer-package): Remove Xemacs special
+ casing. There's already a compatibility defun for
+ match-string-no-properties.
+
+2006-12-13 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * swank.lisp: FIX: fuzzy completion for M-V-B. Fix by Madhu.
+
+2006-12-12 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank.lisp (inspect-for-emacs integer): Pad the hex formatted
+ value to eight digits, "Code-char:" instead of "Corresponding
+ character:", "Integer-length:" instead of "Length:",
+ "Universal-time:" instead of "As time".
+ (inspect-object): Use TYPE-FOR-EMACS instead of TYPE-OF.
+ (inspect-in-emacs): New function, analogous to ED-IN-EMACS.
+
+ * swank-backend.lisp (type-for-emacs): New generic function,
+ defaults to TYPE-OF for non-integers, and returns FIXNUM or BIGNUM
+ for integers.
+
+ * slime.el (destructure-case): Indicate in the error message that
+ it was the Elisp destructure-case that failed to avoid confusion.
+ (slime-check-eval-in-emacs-enabled): More verbose error message.
+
+2006-12-11 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * swank.lisp: Added [set value] command for slot inspecting
+
+ * slime.el: Work on repl history navigation, restore old M-p/M-n
+ behaviour due to #lisp demand
+
+ Also print the current regexp in the minibuffer messages. M-p/M-n
+ takes the repl input up to the point not the entire input as it
+ did before.
+ slime-repl-previous/next-input-starting-with-current-input: new
+ names for the old M-p/M-n commands History navigation commands
+ jump to the end of buffer when point is before the prompt.
+
+ * slime.el: Fix/smarten up temp-buffer-quit
+
+ Now it tries its best to remember the original window config and
+ restore it at slime-temp-buffer-quit unless it was changed
+ meanwhile. IOW, fix "q" after macroexpand in a macroexpand buffer
+ not closing the temp window.
+ Also fix the compiler notes usage of the temp buffer.
+
+ * swank-backend.lisp, swank.lisp:
+ Added inspect-slot-for-emacs to let users customize it.
+
+ Use all-slots-for-inspector everywhere, render link to both the
+ effective and direct slots when both are available. Dropped
+ slot-value-using-class-for-inspector and friends. Added
+ slot-makunbound-using-class to the swank-mop package and added
+ a [make-unbound] action to the standard slot presentation.
+
+ * slime.el: FIX: slime-symbol-name-at-point for symbols like
+ foo::|bar::baz|
+
+ * .cvsignore, swank.lisp: FIX: Drop #\. and add #\, to escaped
+ symbol chars
+
+ * slime.el: Added slime-repl-delete-from-input-history that
+ deletes the current history entry when no input is supplied
+
+ * slime.el: slime-repl-kill-input kills the entire input when
+ point is at the prompt and resets the history navigation state
+
+ * slime.el:
+ Use a hashtable to remove duplicates in slime-repl-merge-histories
+
+2006-12-07 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (init-inspector): Added eval parameter. If NIL we
+ don't eval FORM but limit our selves to cl:read'ing it and
+ inspecting that value.
+
+ * slime.el (slime-inspect): If a prefix argument is provided pass
+ :eval nil to swank:init-inspector.
+
+2006-12-07 Paul Collins <paul(a)briny.ondioline.org>
+
+ * hyperspec.el (common-lisp-hyperspec): Strip all text properties
+ from the symbol-at-point to avoid problems with read-only text.
+
+2006-12-06 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-search-buffer-package): Don't call
+ match-string-no-properties if it's not defined (as is on some
+ xemacs')
+ (slime-repl-clear-buffer): Added optional prefix argument
+ specifying how many lines to leave.
+
+2006-12-06 Johan Bockg�rd <bojohan+sf(a)dd.chalmers.se>
+
+ * swank.lisp (fuzzy-completion-set): Don't mix for clauses and
+ body clauses in loop.
+
+2006-12-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (create-swank-server): Removed. Use create-server
+ instead.
+
+ * slime.el (slime-first-change-hook): Don't do anything if buffers
+ file doesn't exist.
+ (slime-start, slime-set-connection-info): Add support for a
+ :init-function which is called after the usual initialization of the
+ connection is completed.
+
+ * swank-source-file-cache.lisp (buffer-first-change): Always
+ return nil and remove the now redundant test with probe-file.
+
+ * swank-backend.lisp (guess-external-format): Return nil if the
+ file can't be opened. Previusly we wrongly read from stdin.
+
+2006-12-05 Juho Snellman <jsnell(a)iki.fi>
+
+ Real xref support for SBCL (requires SBCL 1.0.0.18).
+
+ * swank-sbcl.lisp (who-calls): New function, fetch xref data from
+ sb-introspect.
+ (who-binds): Ditto.
+ (who-sets): Ditto.
+ (who-references): Ditto.
+ (who-macroexpands): Ditto.
+ (defxref): New macro, create the above functions.
+ (source-location-for-xref-data): New, map from sb-introspect xref
+ format to the Swank xref format.
+ (sanitize-xrefs): Map PCL method names to something more readable.
+ (string-path-snippet): New function, finds a more accurate source
+ snippet for definition source locations which have both an
+ :emacs-string and a full source path available. Otherwise the xref
+ location would point to the toplevel form rather than the exact
+ form for functions compiled with C-c C-c.
+ (source-file-position): New function, somewhat like
+ source-path-file-position but uses the source-file cache, handles
+ missing form-paths more gracefully.
+ (make-definition-source-location): Use the above two functions.
+ (sbcl-with-xref-p): New function, detect whether SBCL has xref support
+ for backwards compability.
+
+2006-11-26 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-source-file-cache.lisp (buffer-first-change): Check
+ whether a file exists before trying load it into the source cache.
+
+2006-11-26 Juho Snellman <jsnell(a)iki.fi>
+
+ Restore the way M-n and M-p used to work in the REPL. (cherry-picked
+ from a patch with other changes, sent by Attila Lendvai).
+
+ * slime.el (slime-repl-previous-input-starting-with-current-input)
+ (slime-repl-next-input-starting-with-current-input): New functions,
+ work like the old slime-repl-previous-input / next-input.
+ (slime-repl-matching-input-regexp): Restore old version.
+ (slime-repl-mode-map): Bind s-r-p-i-s-w-c-i and s-r-n-i-s-w-c-i
+ to M-p and M-n respectively. slime-repl-previous-input and
+ slime-repl-next-input are still accessible with C-up / C-down.
+
+2006-11-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-read-break): Use a :emacs-interrupt message
+ instead of a RPC to swank:simple-break. Suggested by Taylor R
+ Campbell.
+
+2006-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-search-buffer-package): Prettify the package
+ name if it is written as string or keyword.
+
+2006-11-23 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-in-expression-p): Use `read' and `eq' to test
+ the first element of the list. Previuosly, the pattern (foo)
+ wrongly matched (foobar) because we used (looking-at <symbol>).
+
+ * swank-cmucl.lisp (setf-definitions): Also include defs which
+ were created with (defun (setf NAME) ...). Previously we only
+ found definitions created with defsetf or define-setf-expander.
+
+2006-11-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-edit-definition): Don't hide error messages.
+
+2006-11-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*coding-system*): "Coding systems" are now strings
+ instead of keywords.
+
+2006-11-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-compile-file): Let the Lisp side choose the
+ coding system.
+ (slime-coding): Deleted.
+
+ * swank.lisp (compile-file-for-emacs): Use guess-external-format.
+ (swank:create-server): no more accepts an :external-format 'enc ,
+ use :coding-system "enc" instead.
+
+ * swank-backend.lisp (find-external-format)
+ (guess-external-format): New.
+ (swank-compile-file): The external-format argument is now a
+ backend specific value returned by find-external-format.
+
+ * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp,
+ swank-lispworks.lisp, swank-allegro.lisp, swank-corman.lisp,
+ swank-ecl.lisp, swank-scl.lisp, swank-abcl.lisp, swank-openmcl:
+ Update implementations accordingly.
+
+ * swank-source-file-cache.lisp (read-file): Use guess-external-format.
+
+ * swank.lisp (*swank-wire-protocol-version*): Is now initialized
+ by the loader.
+ (wire-protocol-version): Removed, because it contained a reference
+ to swank-loader::*source-directory*.
+
+ * slime.el (slime-set-connection-info): On protocol version
+ mismatch, ask the user how to proceed.
+ (slime-protocol-version): New variable. Initialize it at compile
+ time to detect stale elc files.
+
+ * swank-loader.lisp (load-swank): Set the protocol version.
+
+2006-11-12 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-make-tramp-file-name): Added (require 'tramp)
+ since tramp-make-tramp-file-name is not an autoloaded function.
+
+2006-11-07 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-fuzzy-completion-time-limit-in-msec): Escaped
+ left parenthesis in doc string.
+
+2006-11-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-complete-keywords-contextually): Unused
+ variable, removed.
+
+2006-11-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (sldb-sexp-highlight-mode): Remove bloat.
+
+2006-11-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Support nested presentations in REPL results, when present.lisp is
+ loaded.
+
+ * swank.lisp (make-presentations-result): New, factored out from
+ listener-eval.
+ (listener-eval): Use it here.
+
+ * present.lisp (make-presentations-result): Override it here.
+
+2006-11-03 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (all-slots-for-inspector): Added declare ignore for
+ unused argument inspector (openmcl warns about this). Reindented.
+
+2006-11-01 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (sldb-sexp-highlight-mode): New custom.
+ (slime-handle-repl-shortcut): Trigger slime-lookup-shortcut when
+ the point is anywhere before slime-repl-input-start-mark. IOW,
+ you can press "," anywhere before the prompt.
+ (slime-edit-definition): Handle the case when there are only such
+ entries returned from swank that have errors.
+ (slime-read-from-minibuffer): Allow overriding of the keymap.
+ (slime-repl-previous-matching-input): Similar behaviour like
+ isearch-forward.
+ (slime-repl-next-matching-input): Ditto. In more details: You can
+ freely navigate with slime-repl-previous/next-input with M-p and
+ M-n at any time among the history entries. When M-r is pressed,
+ which invokes slime-repl-previous-matching-input, the the
+ minibuffer is activated to read the regexp to search for and the
+ contents will default to the current repl input. Pressing M-r
+ again will start searching with the last pattern used no matter
+ what the content of the minibuffer is. Subsequent invocations of
+ M-r get the next match, and of course the same applies for M-s,
+ which is slime-repl-previous-matching-input.
+
+ * swank.lisp (fuzzy-completion-set): Fix on clisp.
+ (convert-fuzzy-completion-result): Fix symbol fbound and other
+ annotations.
+ (slot-value-using-class-for-inspector): New.
+ (slot-boundp-using-class-for-inspector): New.
+ (inspect-for-emacs): Use the special slot access methods so that
+ it's possible to customize the inspecting of complex
+ slots (e.g. computed-class at
+ http://common-lisp.net/project/computed-class/).
+ (all-slots-for-inspector): Converted to generic method.
+
+2006-11-01 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (*swank-wire-protocol-version*): Use a defvar to
+ declare the existence of tihs variable to the lisp (Reported by:
+ Jonathon McKitrick <jcm(a)FreeBSD-uk.eu.org>).
+
+2006-10-30 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (*dont-close*): New variable.
+ (defpackage :swank): Export *dont-close*.
+ (start-server, create-server): Use *dont-close* as the default
+ value of the :dont-close parameter.
+ (connection-info): Send the wire-protocol-version (supplied by the
+ swank-version.el file) to slime when connecting.
+ (wire-protocol-version): New function.
+
+ * slime.el (slime-global-variable-name-regexp): New variable.
+ (slime-global-variable-name-p): Use
+ slime-global-variable-name-regexp.
+ ("swank-version"): Load swank-version.el to get the wire protocol
+ version.
+ (slime-set-connection-info): Check the wire protocol version.
+
+2006-10-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-global-variable-name-p): Oops... need to handle
+ very long strings.
+
+2006-10-29 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-global-variable-name-p): Use defun* instead of
+ defun.
+
+2006-10-29 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-global-variable-name-p): Simplified.
+
+2006-10-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Add completion for character names.
+
+ * slime.el (slime-completions-for-character): New.
+ (slime-contextual-completions): Use it here.
+
+ * swank-backend.lisp (character-completion-set): New interface.
+
+ * swank-allegro.lisp (character-completion-set): Implement it.
+
+ * swank.lisp (completions-for-character): New slimefun.
+ (compound-prefix-match/ci/underscores)
+ (longest-completion/underscores, tokenize-completion/underscores)
+ (untokenize-completion/underscores): New functions.
+
+2006-10-28 Ivan Toshkov <ivan(a)toshkov.org>
+
+ * hyperspec.el: Missing Hyperspec links for ~| and ~~
+
+2006-10-27 Ivan Toshkov <ivan(a)toshkov.org>
+
+ * hyperspec.el: Missing Hyperspec links for ~% and ~&
+
+2006-10-27 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank-sbcl.lisp (make-weak-key-hash-table): Restore support
+ for older SBCLs without weak hash-tables.
+ (make-weak-value-hash-table): Ditto.
+
+2006-10-26 Utz-Uwe Haus <haus+slime(a)mail.math.uni-magdeburg.de>
+
+ * swank-allegro.lisp (sldb-break-at-start): Implement.
+
+2006-10-26 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-setup-command-hooks): Use make-local-hook.
+ (slime-repl-mode): Ditto.
+ (slime-fuzzy-choices-buffer): Ditto.
+ (sldb-mode): Ditto.
+ (slime-fuzzy-completion-limit): New variable.
+ (slime-fuzzy-completion-time-limit-in-msec): New variable.
+ (slime-fuzzy-next): Fix when at the end of the buffer.
+ (completion-output-symbol-converter): New to handle escaped
+ symbols for those who need to mess around with symbols like
+ layered-function-definers::|CONTEXTL::SLOT-VALUE-USING-LAYER|.
+ When a symbol is escaped then completion is case sensitive.
+ (completion-output-package-converter): New.
+ (mimic-key-bindings): New to easily define bindings by first
+ trying to look up bindings for an operation and only use the
+ provided default bindings if nothing was found in the source
+ keymap. Use it to set up fuzzy bindings. (Hint: if you have keys
+ like previous-line customized, then only load slime after they
+ have been set, and the fuzzy mode will mimic them.)
+ (slime-temp-buffer-quit): Always close the opened window, updated
+ docstring. Also made the fuzzy maps smarter, they now try to look
+ up keys with 'where-is-internal and map the functions on them.
+
+ * swank-sbcl.lisp
+ (make-weak-value-hash-table): New for sbcl.
+ (make-weak-key-hash-table): New for sbcl.
+
+ * swank.lisp (fuzzy-completions and friends): Added :limit and
+ :time-limit-in-msec keyword params. Used vectors instead of lists
+ that nearly doubled its speed (at least on sbcl). Also added some
+ declare optimize and type annotations.
+ (do-symbols*): New, uses a hash-table to visit only non-seen
+ symbols. Replaced various uses of do-symbols where it was
+ appropiate.
+
+2006-10-26 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-global-variable-name-p): Use a custom 'parser'
+ instead of string-match to avoid regexp overflow errors on very
+ long strings.
+
+2006-10-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-lispworks.lisp (initialize-multiprocessing): Don't init
+ MP if it is already running.
+
+ * test.sh: Run Emacs in Screen.
+
+2006-10-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-backend.lisp, swank-cmucl.lisp:
+ (startup-idle-and-top-level-loops): Deleted. Merged into
+ initialize-multiprocessing.
+
+2006-10-20 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-fuzzy-choices-buffer): Added kill-buffer-hook to
+ the completion buffer to slime-fuzzy-abort, so we get out from the
+ completion mode and key maps when the completion buffer is closed.
+
+2006-10-20 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-target-buffer-fuzzy-completions-map): Fix a bug
+ I introduced when applying levente's patch.
+
+2006-10-20 Martin Simmons <martin(a)lispworks.com>
+
+ * swank-backend.lisp (initialize-multiprocessing): New API to
+ support lisps where initialize-multiprocessing may not return (lispworks).
+
+ * swank.lisp (start-server): initialize-multiprocessing's API has changed.
+
+ * swank-lispworks.lisp (initialize-multiprocessing): Update for new API.
+
+ * swank-cmucl.lisp (initialize-multiprocessing): Update for new API.
+
+ * swank-allegro.lisp (initialize-multiprocessing): Update for new api.
+
+2006-10-20 Levente M�sz�ros <levente.meszaros(a)gmail.com>
+
+ Added "in-place" fuzzy completion GUI. See
+ slime-fuzzy-completions-map and
+ slime-target-buffer-fuzzy-completions-map for details.
+
+ * slime.el (slime-fuzzy-completion-in-place): New variable.
+ (slime-target-buffer-fuzzy-completions-mode): New keymap for
+ in-place fuzzy completions.
+ (slime-fuzzy-target-buffer-completions-mode): New minor mode for
+ in-place fuzzy completions.
+ (slime-fuzzy-current-completion-overlay): New overlay for
+ highlighting currently selected completion.
+ (slime-fuzzy-completions-map): Added new fuzzy completon keys
+ (slime-fuzzy-indent-and-complete-symbol): New function.
+ (slime-fuzzy-complete-symbol): Use new in-place fuzzy completion.
+ (slime-fuzzy-choices-buffer): Support in-place completion editing.
+ (slime-fuzzy-fill-completions-buffer): Highlight completions,
+ don't automatically jump to completion buffer.
+ (slime-fuzzy-enable-target-buffer-completions-mode,
+ slime-fuzzy-disable-target-buffer-completions-mode): New modes for
+ moving in/out of in-place fuzzy completion mode
+ (slime-fuzzy-next, slime-fuzzy-prev): Don't assume point is in the
+ completion buffer.
+ (slime-fuzzy-dehighlight-current-completion,
+ slime-fuzzy-highlight-current-completion): Manage completion
+ selection highlighting.
+ (slime-fuzzy-select-or-update-completions): New function.
+ (slime-fuzzy-process-event-in-completions-buffer): New function.
+ (slime-fuzzy-select-and-process-event-in-target-buffer): New function.
+ (slime-fuzzy-done): Changed to deal with in-place completion.
+
+2006-10-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-backend.lisp (ignored-xref-function-names): Deleted.
+
+ * swank.lisp (guess-package-from-string): Remove special case for
+ "#.". parse-package will handle that just fine.
+ (find-definitions-for-emacs): Don't filter errors out.
+ (sanitize-xrefs): Moved to swank-sbcl. The backend is supposed to
+ return sane values.
+
+ * swank-sbcl.lisp: See above.
+
+ * slime.el (slime-find-buffer-package): Simplify.
+
+2006-10-17 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-accept-process-output): The timeout arg can be
+ nil. Handle that case.
+
+2006-10-17 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime.el (slime-find-buffer-package): Handle #. forms.
+
+ * swank.lisp (guess-package-from-string): Handle #. forms.
+ (inspect-for-emacs standard-class): Handle non-string
+ :documentation slot contents.
+
+ * swank-sbcl.lisp (inspect-for-emacs weak-pointer ...): Added
+ method.
+
+2006-10-16 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (sldb-activate): Get debug-info from the correct
+ thread. Fixes bug reported by Dan Weinreb <dlw(a)itasoftware.com>.
+ (unwind-to-previous-sldb-level): New test.
+ (slime-init-command): Send a single form.
+ (slime-insert-presentation): Honor slime-repl-enable-presentations.
+ Presentations kill SLDB and the inspector in Emacs 20 (besides
+ being troublesome GC-wise).
+
+ * swank.lisp: Clean up global IO redirection.
+ (setup-stream-indirection): Turn macro into a
+ function and delay initialization after user init files are
+ loaded, so that we do nothing if *globally-redirect-io* is nil.
+ (*after-init-hook*, run-after-init-hook)
+ (init-global-stream-redirection): New.
+
+ (parse-symbol-or-lose): Lose loudly and early (instead of failing
+ silently).
+
+ * swank-loader.lisp: Abort on compile-time or load-time errors.
+ Don't try to load the source-file if COMPILE-FILE's 3rd return
+ value is true (it's true even for warnings).
+ (handle-loadtime-error): New function.
+
+ Run the after-init-hook.
+
+ * swank-cmucl.lisp (inspect-for-emacs): Don't break for
+ simple-strings.
+
+2006-10-11 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-syntax-table): New.
+ (slime-add-presentation-properties): Install it in a syntax-table
+ text property, so that #<...> is balanced in a presentation.
+ (slime-remove-presentation-properties): Remove the text property.
+ (slime-repl-mode): Respect the syntax text properties of
+ presentations in REPL buffers.
+
+2006-10-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (completions-for-keyword): Look up the operator names
+ in the right package. Return nil (rather than signalling an
+ error) when no valid operator name is present.
+
+2006-10-08 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-loader.lisp (lisp-version-string) [allegro]: Distinguish
+ between 32-bit and 64-bit version on the SPARC architecture.
+
+2006-10-03 Marco Baringer <mb(a)bese.it>
+
+ Change license statement to say that all files without an explicit
+ copyright notice are public domain. This change will allow SLIME
+ to moved out of debian's nonfree tree.
+
+ * README: Update license statement.
+
+2006-10-02 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-highlight-compiler-notes): New variable.
+ (slime-compilation-finished): Only highlight notes when
+ slime-highlight-compiler-notes is non-NIL.
+
+2006-09-28 Marco Baringer <mb(a)bese.it>
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Don't
+ ignore compile-time errors but drop into a debugger (it's not a
+ slime debugger but it's certainly better than ignoring the error).
+
+2006-09-27 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (*globally-redirect-io*): Change default value to T.
+
+2006-09-25 Juho Snellman <jsnell(a)iki.fi>
+
+ Fix Slime on SBCL 0.9.17.
+
+ * swank-backend.lisp (ignored-xref-function-names): New interface
+
+ * swank.lisp (sanitize-xrefs): Use ignored-xref-function-names
+ instead of having a #+sbcl special case.
+
+ * swank-sbcl.lisp (ignored-xref-function-names): Implement.
+ Filter out SB-C::STEP-VALUES, not just SB-C::STEP-FORM, as done by
+ the old sanitize-xrefs. Don't implement the interface at all if
+ SBCL is sufficiently new (those symbols don't exist any more, and
+ there's nothing in their place to be ignored).
+
+2006-09-21 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (find-definitions-for-emacs): Don't return locations
+ whose CAR is :error.
+ (xref): Process whatever is returned by the various xref functions
+ with the new sanitize-xrefs functions.
+ (sanitize-xrefs): Clean up the list of xrefs to remove duplicates.
+ Patch by Dan Weinreb <dlw(a)itasoftware.com>
+
+ * slime.el (slime-goto-first-note-after-compilation): New
+ variable. This controls the behaviour of (next|prev)-note
+ immediatly after a slime-compile-and-load-file.
+ (slime-compilation-just-finished): New variable.
+ (slime-compilation-finished): Update slime-compilation-finished.
+ (slime-next-note, slime-previous-note): Respect
+ slime-compilation-just-finished.
+ (slime-autodoc-use-multiline-p): Specify the type.
+ (slime-repl-grab-old-input): Typo in docstring.
+ (slime-cheat-sheet): Deal with multiple-bindings
+ (slime-cheat-sheet-table): Update as per #lisp's suggestions.
+
+2006-09-20 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-cheat-sheet): New function.
+ (slime-cheat-sheet-table): New variable which specifies what the
+ cheat sheet should list.
+ (slime-read-package-name): Set require to T in the call to
+ completing read, it doesn't make any sense to switch to an
+ inexistent package.
+
+ * doc/slime.texi: Added "Tips and Tricks" chapter (need a better
+ name for this).
+
+ * swank-sbcl.lisp (fallback-source-location): Use abort-request
+ instead of error.
+ (locate-compiler-note): Say, in the error message, what data
+ caused the error.
+
+2006-09-20 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (call-with-debugger-hook): use INVOKE-STEPPER
+ instead of calling the stepper hook manually
+
+2006-09-19 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (call-with-debugger-hook): make the stepper
+ also work with a threaded SBCL, by binding a handler for
+ sb-ext:stepper-condition instead of relying on the one that SBCL
+ establishes on the toplevel
+
+2006-09-19 Juho Snellman <jsnell(a)iki.fi>
+
+ Extend the stepper protocol to work nicely with the SBCL stepper.
+
+ If sldb is invoked on a condition that's sldb-stepper-condition-p,
+ the sldb functions sldb-step, sldb-next and sldb-out will invoke
+ the matching backend functions for stepping into the stepped form,
+ to the next form, or out of the current function. Otherwise the
+ functions will behave like sldb-step used to (call active-stepping and
+ select the continue restart).
+
+ * swank-backend.lisp (sldb-stepper-condition-p, sldb-step-into,
+ sldb-step-next, sldb-step-out): New interface functions
+
+ * swank-sbcl.lisp (activate-stepper, condition-extras,
+ sldb-stepper-condition-p, sldb-step-into, sldb-step-next,
+ sldb-step-out): Implemented (conditional on CVS SBCL)
+ (call-with-debugger-hook): bind sb-ext:*stepper-hook* to
+ a function that binds *stack-top-hint* and invokes the debugger
+ (conditional on CVS SBCL)
+
+ * swank.lisp (define-stepper-function): new macro for defining
+ stepper-related functions, since they all follow the same form
+ (sldb-step): redefine with define-stepper-function
+ (sldb-next, sldb-out): new functions
+ (*sldb-stepping-p*): typo in docstring
+
+ * slime.el (sldb-next, sldb-out): New commands
+ (sldb-mode-map): bind sldb-next to "x" and sldb-out to "o"
+
+2006-09-18 Dan Weinreb <dlw(a)itasoftware.com>
+
+ For those cases where SLIME can't complete a user request (like
+ loading an asdf system without asdf or describing an inexistent
+ symbol) instead of signaling an error SWANK should politely inform
+ the user and return normally.
+
+ * swank.lisp (eval-for-emacs): Handle request-abort conditions.
+ (decode-keyword-arg, get-repl-result, parse-symbol-or-lose): Use
+ abort-request instead of error.
+
+ * swank-backend.lisp (request-abort): New condition.
+ (abort-request): Convenience function for signaling request-abort
+ conditions.
+ (operate-on-system): Use abort-request instead of error
+ (:swank-backend): Export the symbols abort-request and
+ request-abort.
+
+ * slime.el (slime-rex): Update docstring.
+ (slime-eval, slime-eval-async): Added new REASON parameter sent
+ along with :abort message.
+
+2006-09-14 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl (arglist, function-arglist, spawn): update for the SCL.
+
+2006-09-13 Brandon Bergren <bdragon(a)mailsnare.net>
+
+ * slime.el (slime-filename-translations): Fix docstring
+
+2006-09-13 Bob Halley <halley(a)play-bow.us>
+
+ * swank.lisp (format-iso8601-time): Properly handle non integer
+ time zones.
+
+2006-09-13 Taylor R Campbell <campbell(a)mumble.net>
+
+ * slime.el (slime-init-output-buffer): Initial directory and
+ package stacks should be empty.
+ (slime-repl-push-package): Push the current package, as opposed to
+ the new package, and set the new package to whatever the user
+ specified.
+ (slime-repl-pop-package): Set the current package to the top of
+ the package stack, unless it's empty.
+
+2006-09-13 Daniel Koning <dkoning(a)seas.smu.edu>
+
+ * slime.el (slime-repl-disconnect): New repl shortcut.
+
+2006-09-13 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-open-inspector): Added a slime-part-number
+ property to the topline so that you can slime-inspector-copy-down
+ the object being inspected. There are some cases where we have an
+ object in the inspector and we'd like to dump it to the repl but
+ we can't get at it through other means (like in back-traces).
+ (slime-insert-xrefs): Specify which file the item is in (when that
+ information is available).
+
+ * swank.lisp (format-arglist-for-echo-area): Instead of using
+ let+first+rest to destructure a form use destructuring-bind.
+ (lookup-presented-object): Added (declare (special
+ *inspectee-parts*)) to silence openmcl's compiler.
+ (inspect-object): Generate, and send to emacs, an ID for the
+ object being inspected.
+
+2006-09-01 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * slime.el (slime-repl-matching-input-regexp): Use the portion
+ between slime-repl-input-mark and point for history search, not
+ the entire input. Patch by Ivan Shvedunov.
+
+ * swank-sbcl.lisp: Declaim SB-C:INSERT-STEP-CONDITIONS 0 for to
+ hide Swank while stepping and avoid endless mutex-acquisition
+ loops.
+
+2006-08-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (input-available-p, process-available-input): Use
+ READ-CHAR-NO-HANG instead of LISTEN because LISTEN suddenly
+ returns false in SBCL 0.9.?? even if we are called from a
+ fd-handler and the OPEN-STREAM-P returns true.
+
+2006-08-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-return-behaviour): Fix the defcustom type,
+ so Emacs 21.3 does not signal an error when creating a
+ customization buffer containing this variable.
+
+2006-08-25 Kai Kaminski <kai.kaminski(a)gmx.de>
+
+ * swank.lisp (lookup-presented-object): Fix for OpenMCL 1.0
+ [ppc32], which requires that the :NO-ERROR clause is last in
+ HANDLER-CASE.
+
+2006-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-ensure-presentation-overlay): Provide a
+ help-echo for presentations, showing the mouse bindings.
+ (slime-presentation-around-click): New function.
+ (slime-copy-or-inspect-presentation-at-mouse)
+ (slime-inspect-presentation-at-mouse)
+ (slime-copy-presentation-at-mouse)
+ (slime-describe-presentation-at-mouse)
+ (slime-pretty-print-presentation-at-mouse): New commands.
+ (slime-copy-presentation-at-point): Removed (misnomer).
+ (slime-presentation-map): Bind mouse-2 to
+ slime-copy-or-inspect-presentation-at-mouse, so the right thing is
+ done in REPL buffers and in Inspector and Debugger buffers.
+ (slime-menu-choices-for-presentation): Use the new commands here
+ instead of inline lambdas.
+ (sldb-inspect-in-frame): Use slime-read-object here, so if point
+ is in a presentation in the debugger buffer, inspect it
+ immediately just like slime-inspect does.
+ (slime-inspect-presented-object): Removed.
+ (slime-inspect): Don't expect that "swank:init-inspector" is
+ already part of the form. Accept an optional arg "no-reset".
+ (slime-read-object): Don't add "swank:init-inspector" to the read
+ form; slime-inspect now adds it.
+
+2006-08-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Make the values of local variables in debugger frames and values
+ of parts in the inspector accessible as presentations. In
+ particular, this allows to copy #<unreadable> values to the REPL
+ for further investigation. It also provides a context menu for
+ the values, offering to inspect, pretty-print, and describe them.
+
+ Note that the presentations are only valid as long as the
+ corresponding Inspector or Debugger buffer is open.
+
+ * swank.lisp (lookup-presented-object): Handle presentation ids
+ (:frame-var frame index), (:inspected-part part-index).
+ (init-inspector): New optional argument, reset.
+
+ * slime.el (slime-inspector-insert-ispec): Mark up all values of
+ inspected parts as presentations.
+ (sldb-insert-locals): Mark up the values of local variables as
+ presentations.
+ (slime-remove-presentation-properties): Fix for read-only buffers.
+ (slime-copy-presentation-at-point): Make it work when the current
+ buffer is not the REPL buffer.
+ (slime-menu-choices-for-presentation): Describe into a separate
+ buffer, not the REPL. New menu item, pretty-print.
+ (slime-presentation-expression): Handle presentation ids that are
+ not numbers.
+ (slime-inspect-presented-object): Don't reset the inspector if
+ already in the inspector buffer.
+
+2006-08-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (*nil-surrogate*): New.
+ (save-presented-object, lookup-presented-object): Distinguish
+ between a saved NIL and a garbage-collected object that was
+ replaced by NIL in the weak hash table.
+ (compute-enriched-decoded-arglist with-open-file): Add an IGNORE
+ declaration.
+
+2006-08-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-parse-extended-operator-name/apply): New.
+ (slime-extended-operator-name-parser-alist): Add it to the alist.
+
+ * swank.lisp (compute-enriched-decoded-arglist): Add method for
+ handling APPLY.
+
+2006-08-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-accept-process-output): Use brute-force to
+ detect whether accept-process-output can be called with a float as
+ timeout arg.
+
+ * swank-openmcl.lisp: Fix some breakage caused by the new
+ defimplementation.
+
+2006-08-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (close-connection, swank-error): Include backtraces
+ in our own errors.
+ (simple-serve-requests): Don't try to enter the
+ debugger if the connection is closed.
+
+ * slime.el (disconnect): Test disconnecting.
+
+ * swank-cmucl.lisp (startup-idle-and-top-level-loops): Initialize
+ MP only once.
+
+2006-08-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp (fspec-definition-locations): Improve
+ handling of (:internal ... n) like fspecs.
+
+ * slime.el (slime-restart-inferior-lisp-aux): Remove the
+ interactive spec.
+
+ * swank-backend.lisp (definterface): Drop that incredibly
+ unportable CLOS stuff. Use plists and plain functions instead.
+ Update backends accordingly.
+
+2006-08-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-find-filename-translators): CL:MACHINE-INSTANCE
+ can return nil. Silently accept that case for now.
+
+ * swank.lisp (test-print-arglist): Print a message instead of
+ signalling an error. This should avoid startup problems, in
+ particular with CormanLisp.
+ (setup-stream-indirection): Disable it for now. We should fix it,
+ if there is a need for this functionality or just remove it.
+
+ * swank-backend.lisp (definterface): Bring the old implementation
+ based on NO-APPLICABLE-METHOD back. It avoids lots of redefintion
+ warnings (but it creates more "noise" in backtraces).
+
+ * swank-*.lisp (inspect-for-emacs): Don't use defimplementation
+ for real generics.
+
+2006-07-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-thread-quit): Call swank:quit-thread-browser.
+ Reported by Taylor R Campbell.
+
+2006-07-28 Willem Broekema <metawilm(a)gmail.com>
+
+ * swank-allegro.lisp: Profiling functions on Allegro (except for
+ profile-package).
+
+2006-07-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Add support for destructuring macro arglists in arglist display,
+ form completion, and keyword completion; in particular for
+ with-open-file.
+
+ * swank.lisp (find-valid-operator-name): New, factored out from
+ arglist-for-echo-area.
+ (arglist-for-echo-area): Use it here.
+ (print-arglist): New, factored out from decoded-arglist-to-string.
+ Handle recursive arglist structures that arise in destructuring
+ macro arglists.
+ (decode-required-arg, encode-required-arg): New, handle
+ destructuring patterns.
+ (decode-keyword-arg, encode-keyword-arg, decode-optional-arg)
+ (encode-optional-arg, decode-arglist, encode-arglist): Use them
+ here to handle destructuring patterns.
+ (print-decoded-arglist-as-template): Change interface, handle
+ destructuring patterns.
+ (decoded-arglist-to-template-string): Use it here.
+ (enrich-decoded-arglist-with-keywords): New, factored out from
+ enrich-decoded-arglist-with-extra-keywords.
+ (enrich-decoded-arglist-with-extra-keywords): Use it here.
+ (compute-enriched-decoded-arglist): New generic function, factored
+ out from arglist-for-insertion, form-completion. Add specialized
+ method for with-open-file.
+ (arglist-for-insertion, form-completion): Use it here.
+ (arglist-ref): New.
+ (completions-for-keyword): Change interface, handle destructuring
+ macro arglists.
+
+ * slime.el (slime-enclosing-operator-names): For nesting levels
+ without operator, record nil.
+ (slime-completions-for-keyword): New argument arg-indices.
+ (slime-contextual-completions): Pass all enclosing operators and
+ arg-indices to slime-completions-for-keyword.
+
+2006-07-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-edit-definition): Invoke the
+ slime-edit-definition-fall-back-function also in the case where
+ find-definitions-for-emacs returns an error message.
+ (slime-edit-definition-fallback-function): Fix typo (find-tag
+ rather than find-tags).
+
+2006-07-15 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (preferred-communication-style): Remove use of
+ linux_no_threads_p alien variable (the value has been hardcoded to
+ false for about a year), so that we can also remove it from from SBCL
+ in the future.
+ (*definition-types*): defcondition -> define-condition,
+ to make slime-show-definitions display condition FOO as
+ (DEFINE-CONDITION FOO) instead of (SWANK-BACKEND::DEFCONDITION FOO).
+
+2006-07-15 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-shared-lisp-mode-hook): New function, factored
+ out from slime-lisp-mode-hook.
+ (slime-lisp-mode-hook): Use it here.
+ (slime-scheme-mode-hook): New function, use
+ slime-shared-lisp-mode-hook.
+ (slime-setup): If scheme-mode is one of the slime-lisp-modes,
+ install our hook.
+
+2006-07-13 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (keywords-of-operator): New support function for
+ writing user-defined `extra-keywords' methods.
+
+2006-07-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak
+ hashtables.
+
+ * swank.asd: Set *source-directory* to the asdf component dir.
+
+2006-07-01 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ * swank-sbcl.lisp (locate-compiler-note): Change first branch to
+ handle the changes introduced by the previous patch to
+ swank-compile-string.
+
+2006-06-26 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (find-definitions): Remove backward
+ compatibility code.
+
+2006-06-26 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ * swank-sbcl.lisp (tmpnam, temp-file-name): New functions.
+ (swank-compile-string): Create temporary file with the string and
+ compile-file it instead of compiling an anonymous lambda, as
+ before, in order to better handle eval-when forms.
+
+2006-06-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-source-path-parser.lisp (suppress-sharp-dot): Return a
+ unique symbol to avoid multiple entries for nil at toplevel in the
+ source-map.
+
+ * slime.el (test compile-defun): Add a test for #. reader macro at
+ toplevel.
+ (slime-run-one-test): New command.
+ (sldb-activate): Recreate the sldb buffer if it doesn't
+ exist. (Can happen if someone kills the buffer manually.)
+ (slime-wait-condition): Add a dummy to slime-stack-eval-tags while
+ waiting so that the SLDB enters a recursive edit.
+
+2006-06-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-echo-arglist): Simplify, just use slime-autodoc.
+
+ * swank.lisp (arglist): Distinguish between provided actual args
+ and required formal args using the new slot provided-args.
+ (form-completion): Likewise.
+ (decoded-arglist-to-string): Use it here to display the argument
+ list (make-instance 'CLASS-NAME ...) rather
+ than (make-instance (quote CLASS-NAME) ...).
+
+ * swank.lisp (extra-keywords change-class): Don't drop the first
+ argument.
+
+ * slime.el (slime-parse-extended-operator-name): Don't move
+ point; fixes infinite loop.
+
+2006-06-17 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-parse-extended-operator-name/cerror): Handle
+ cerror and change-class with :make-instance.
+ (slime-extended-operator-name-parser-alist): Handle change-class.
+ (slime-parse-extended-operator-name)
+ (slime-enclosing-operator-names): Fix the case when point is
+ within the operator.
+
+ * swank.lisp (operator-designator-to-form): Handle cerror and
+ change-class with :make-instance.
+
+2006-06-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (operator-designator-to-form): Handle :cerror.
+ (extra-keywords cerror): Make it work.
+
+ * slime.el (slime-parse-extended-operator-name)
+ (slime-parse-extended-operator-name/make-instance)
+ (slime-parse-extended-operator-name/defmethod): New functions,
+ factored out from slime-enclosing-operator-names.
+ (slime-parse-extended-operator-name/cerror): New function.
+ (slime-extended-operator-name-parser-alist): New variable.
+ (slime-enclosing-operator-names): Use them here.
+
+2006-06-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-goto-definition): If all definitions of a name
+ have the same location, go there directly rather than presenting
+ an xref buffer.
+
+2006-06-11 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl (ext:stream-write-chars): update for SCL 1.3.
+
+2006-06-09 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-abcl: Update to cvs version of abcl and warnings errors
+ when compiling in a buffer will now be properly caught by slime vs
+ current behavior of always saying 0 errors 0 warnings and printing
+ them in the repl instead
+
+2006-05-31 Nathan Bird <nathan(a)acceleration.net>
+
+ * swank.lisp (*sldb-quit-restart*): New variable.
+ (throw-to-toplevel): Use the restart named by *sldb-quit-restart*
+ as opposed to hard coding abort-request.
+
+2006-05-30 Tobias Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-get-temp-buffer-create): New keyword REUSEP
+ which indicates whether an already-existing buffer named like the
+ buffer to be created should be reused, i.e. not killed, then
+ freshly created. Update docstring accordingly.
+ (slime-with-output-to-temp-buffer): Make &optional arg MODE an
+ &key keyword arg. Add REUSEP keyword.
+ (slime-macroexpansion-minor-mode-map): Make remapped `undo' update
+ highlighted edits in the macroexpansion buffer.
+ (slime-eval-macroexpand-in-place): Update highlighted edits when
+ macroexpanding in-place.
+ (slime-eval-macroexpand): Reuse macroexpansion buffer if it exists
+ already to preserve `undo' functionality.
+
+2006-05-30 Tobias Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-use-autodoc-mode): Fix typo in docstring.
+ (slime-use-highlight-edits-mode): New variable, analogous to
+ SLIME-USE-AUTODOC-MODE.
+ (slime-setup, slime-lisp-mode-hook): Make above variable
+ work. Also, activates the HIGHLIGHT-EDITS-MODE in proper way (thus
+ avoiding the nasty "Toggling ... off; better pass an explicit
+ argument." message.)
+
+ * slime.el: Fix typo in comment about communication protocol.
+
+2006-05-27 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-abcl: slot-boundp-using-class slot-value-using-class so you
+ can inspect instances
+
+2006-05-26 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime.el (slime-eval-macroexpand-inplace): Fix out-of-range
+ error on in-place macroexpand when point is placed at a closing
+ parenthesis. In this case the sexp closed by that paren is
+ expanded.
+ Also make expanding of expressions work that are quoted like, for
+ instance, "'(FOO BAR)" if point is placed at the opening paren.
+
+2006-05-24 Brian Downing <bdowning(a)lavos.net>
+
+ * swank.lisp (recursively-compute-most-completions & friends):
+ Micro-optimize the fuzzy completion engine, improving performace
+ by a factor of about 4 on SBCL. However, it will only work on
+ simple-strings now, and CHAR= is burned in instead of being an
+ option. I don't think this is too much of a limitation. At this
+ point rendering the results on the emacs side takes much longer
+ than finding them for long result lists.
+
+2006-05-24 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-abcl: Add some more mop functions to you can inspect classes,
+ generic functions, methods, slots.
+
+2006-05-16 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-repl-return-behaviour): New variable which
+ controls slime-repl-return's heaviour.
+ (slime-repl-return): Respect slime-repl-return-behaviour.
+
+2006-05-14 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-macroexpansion-minor-mode-map): Rebind 'undo' to
+ set buffer-read-only temporarily to t.
+ (slime-repl-return): Only send repl input if point is past a
+ complete form.
+
+2006-05-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (update-indentation-information): Fix for problem
+ with Allegro CL 8.0: If I type M-x slime-update-indentation,
+ Allegro CL starts growing until it hits a STORAGE-CONDITION or
+ even segfaults.
+
+2006-05-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-allegro.lisp (fspec-definition-locations): Handle
+ :top-level-form entries that appear in backtraces.
+
+2006-04-20 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (toggle-trace): Implemented. Currently only
+ provides 'best effort' support, :labels and :flet are ignored,
+ :defmethod and :call are treated like a normal trace of the
+ operator.
+
+2006-04-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*use-dedicated-output-stream*): Make it nil by
+ default to avoid race conditions.
+
+2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * doc/Makefile (contributors.texi): use texinfo macros for
+ accented characters.
+
+ * ChangeLog: canonize Gabor Melis' spelling, otherwise he appears
+ twice in the "Hackers of the good Hack table"
+
+ * doc/slime.texi (nyorsko): delete
+ (EDITION): make it say 2.0
+
+2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank.lisp (decoded-arglist-to-string): if the keyword and the
+ variable are different, print the keyword name with escapes.
+ (encode-keyword-arg): get the keyword and the arg-name the same
+ way round as in lambda lists.
+ (appliable-methods-keywords): use
+ swank-mop:compute-applicable-methods-using-classes and
+ compute-applicable-methods in the AMOP-friendly way, to get EQL
+ specializers right.
+ (class-from-class-name-form, extra-keywords/slots): new.
+ (extra-keywords/make-instance): use new functions. Also get
+ keywords from SHARED-INITIALIZE (after Dan Barlow) and
+ ALLOCATE-INSTANCE.
+ (extra-keywords/change-class): new.
+ (extra-keywords (eql 'change-class)): new. Won't work at present,
+ just as the CERROR case doesn't work.
+
+2006-04-19 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank-sbcl.lisp (preferred-communication-style): Make it nil
+ under win32, for now.
+
+ * doc/slime.texi: document nil *communication-style*
+
+2006-04-18 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-corman.lisp: Define a class file-stream to let swank.lisp
+ load.
+
+2005-04-17 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp: (accept-connection): New argument: timeout.
+
+2006-04-14 Gerd Flaig <gefla(a)pond.sub.org>
+
+ * slime.el (slime-autodoc): Fix reference to unbound variable.
+
+2006-04-13 Martin Simmons <martin(a)lispworks.com>
+
+ * swank-loader.lisp (load-site-init-file, swank-source-files): Fix
+ pathname construction to take all unspecified components from the
+ directory pathname, in particular the drive letter on Windows.
+
+2006-04-13 Helmut Eller <helmut(a)common-lisp.net>
+
+ * slime.el (slime-find-filename-translators): Use assoc-if instead
+ of assoc-default for XEmacs compatibility.
+ (slime-show-note-counts): Don't show the highlighting bit as it
+ spills of the screen.
+ (slime-highlight-notes): Use with-temp-message.
+ (with-temp-message): Define it for XEmacs.
+ (slime-beginning-of-symbol): Use eq instead of char-equal as
+ char-equal signals an error at the beginning of a buffer.
+
+2006-04-13 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl (make-socket-io-stream): set the stream to ignore
+ character conversion errors, and to substitute the character #\?.
+ Without this the communication channel is prone to lockup when a
+ conversion error occurs.
+
+ * swank-scl (inspect-for-emacs function): correct the index into the
+ closure environment; it was reading off the end of the closure
+ environment and picking up a corrupting value.
+
+ * swank-scl (mailbox): rework the mailbox implementation to better
+ handle interruption. Use a polling loop rather than condition
+ variables because interrupting a condition variable wait leaves the
+ thread with the condition variable lock held and leads to a deadlock
+ error.
+
+2006-04-12 Robert Macomber <slime(a)rojoma.com>
+
+ * swank-backend.lisp (make-recursive-lock): New interface
+ function.
+ (call-with-recursive-lock-held): New interface function.
+
+ * swank-grey.lisp (class slime-output-stream): Added recursive
+ locking to class and generic functions specialized on it.
+ (clss slime-input-stream): Added recursive locking to class and
+ generic functions specialized on it.
+
+ * swank-sbcl.lisp (make-recursive-lock): Implement the new interface.
+ (call-with-recursive-lock): Implement the new interface.
+
+2006-04-01 Matthew D. Swank <akopa(a)charter.net>
+
+ * slime.el (slime-fontify-string): Use set-text-properties, not
+ propertize, for Emacs 20 compatibility.
+
+2006-03-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-init-command): Don't translate filenames since
+ the new scheme doesn't work without a connection.
+ (slime-to-lisp-filename,slime-from-lisp-filename): Remove some
+ redundancy.
+ (slime-macroexpansion-minor-mode): Make it Emacs 20 compatible.
+
+2006-03-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-mode): Enable autodoc-mode if
+ slime-use-autodoc-mode is true.
+
+2006-03-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (multiple-value-or): New macro.
+
+ * slime.el (slime-recently-visited-buffer): Ignore internal
+ buffers (starting with a space), to avoid selecting the
+ *slime-fontify* buffer. Reported by Andreas Fuchs.
+
+ * slime.el (slime-enclosing-operator-names): Handle forms similar
+ to make-instance (make-condition, error, etc.), to get extra
+ keywords based on the condition class.
+
+ * swank.lisp (operator-designator-to-form): Handle forms similar
+ to make-instance (make-condition, error, etc.)
+ (extra-keywords/make-instance): New function.
+ (extra-keywords): Specialize on operators make-condition, error,
+ signal, warn, cerror. Use multiple-value-or.
+
+2006-03-27 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-make-tramp-file-name): If emcas' tramp has
+ tramp-multi-methods then pass the method parameter to
+ tramp-make-tramp-file-name, otherwise don't.
+ (slime-create-filename-translator): Use
+ slime-make-tramp-file-name.
+
+2006-03-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * hyperspec.el (common-lisp-hyperspec-strip-cl-package): New
+ function.
+ (common-lisp-hyperspec): Don't get confused by a cl: or
+ common-lisp: package prefix.
+
+ * slime.el (slime-hyperspec-lookup): Don't get confused by a cl:
+ or common-lisp: package prefix.
+
+2006-03-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-enclosing-operator-names): Fix for situation
+ when point is at end of buffer, as it happens often in the REPL.
+
+2006-03-25 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (arglist-for-echo-area): New keyword arg,
+ print-lines.
+ (decoded-arglist-to-string): New function, implement argument
+ highlighting also for &optional and &rest/&body arguments.
+ (arglist-to-string): Use decoded-arglist-to-string.
+ (arglist): New slots aux-args, known-junk, unknown-junk.
+ (nreversef): New macro.
+ (decode-arglist, encode-arglist): Refine to handle more structure
+ in argument lists, including implementation-defined stuff like
+ &parse-body.
+ (format-arglist-for-echo-area): New keyword arg, print-lines.
+ Simplify the code as there is no need to fall back to the unparsed
+ arglist any more.
+
+ * slime.el (slime-fontify-string): Fix for arguments spanning
+ multiple lines.
+ (slime-autodoc-message-dimensions): New.
+ (slime-autodoc-thing-at-point): Use it here to either ask for a
+ one-line or a nicely formatted multi-line arglist.
+ (slime-enclosing-operator-names): Handle linebreaks.
+
+2006-03-24 Mikel Bancroft <mutandiz(a)yahoo.com>
+
+ * swank-allegro.lisp (set-default-directory): Fix for pathnames
+ without a trailing slash.
+
+2006-03-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-background-activities-enabled-p): Allow
+ "background activities" in sldb-mode.
+ (slime-autodoc-message-ok-p): Allow autodoc in sldb-mode.
+ (sldb-mode-syntax-table): New variable.
+ (sldb-mode): Enable autodoc-mode when slime-use-autodoc-mode is
+ true. Use sldb-mode-syntax-table to make #<...> balance like
+ parentheses. This enables autodoc-mode to match #<unreadable>
+ actual arguments in the backtraces with formal arguments of the
+ function.
+ (slime-beginning-of-symbol, slime-end-of-symbol): Handle
+ es::|caped| symbols.
+ (slime-enclosing-operator-names): Use syntax table to check
+ whether we are at the beginning of a balanced expression.
+
+2006-03-23 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank.lisp (ed-in-emacs): Allow conses as function names.
+ Ensure that there is a connection to emacs before sending the
+ :ed message.
+
+ * slime.el (slime-edit-definition): read names, not symbols.
+ (slime-ed): handle conses whose car is not a string as function
+ names.
+
+2006-03-23 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-qualify-cl-symbol-name): Strip leading colon
+ from package names for qualifying symbols.
+ (slime-call-defun): New command.
+ (slime-keys): Bind it to C-c C-y.
+ (slime-easy-menu): Show it in the menu.
+
+ * slime.el (slime-autodoc-use-multiline-p): New defcustom.
+ (slime-autodoc-message): Use it here. Fix bug that autodoc
+ messages exceeding one line could not be overwritten by later
+ autodoc messages.
+ (slime-autodoc-pre-command-refresh-echo-area): Use message
+ rather than slime-background-message.
+
+ * swank.lisp (casify): Removed.
+ (casify-char, tokenize-symbol-thoroughly): New functions.
+ (parse-symbol): Use tokenize-symbol-thoroughly, so as to handle
+ |escaped symbols|. This fixes arglist display for operators with
+ strange symbol names.
+
+2006-03-23 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-backend (accept-connection): add a 'timeout argument to
+ this function.
+
+ * swank-backend (set-stream-timeout): new implementation specific
+ function. Used to set the timeout for stream operations, which
+ can help make the network connection establishment more robust.
+
+ * swank (setup-server): ignore errors from the function 'serve to
+ allow another connection to be made.
+
+ * swank (serve-connection): ensure the listener socket is closed
+ when 'dont-close is false, even if the connection attempt fails.
+
+ * swank (accept-authenticated-connection): ensure the new
+ connection is closed if the connection establishment fails. Set a
+ short stream timeout to prevent denial of survice.
+
+ * swank (open-dedicated-output-stream): ensure the listener socket
+ is closed, even if unable to open the dedicated stream. Implement
+ a timeout while waiting for a connection for the dedicate stream
+ to prevent denial of service.
+
+ * swank (create-connection): ensure the new connection is closed
+ if not successful.
+
+2006-03-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (arglist-for-echo-area): Fix when arg-indices are
+ not given.
+
+ * slime.el (slime-ed): Handle (FILENAME :charpos CHARPOS).
+
+ * swank.lisp (inspect-for-emacs): Specialize on FILE-STREAM and
+ STREAM-ERROR, offering to visit the file at the current stream
+ position as an inspector action. Useful for dealing with reader
+ errors.
+
+2006-03-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-autodoc-pre-command-refresh-echo-area):
+ Show the last autodoc message again (movement commands clear it);
+ technique to avoid flickering, taken from eldoc.
+ (slime-autodoc-mode): Install it as a pre-command-hook.
+ (slime-autodoc-last-message): New variable.
+ (slime-autodoc-message): New function.
+ (slime-autodoc): Use them here.
+ (slime-autodoc-message-ok-p): OK to overwrite an autodoc message.
+
+ * slime.el (slime-handle-indentation-update): Also update
+ scheme-indent-function if slime-lisp-modes contains scheme-mode.
+
+2006-03-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Highlight the formal argument corresponding to the actual
+ argument around point in the echo-area arg-list display.
+ Works most impressively when slime-autodoc-mode is enabled
+ and when one has to deal with extremely long argument lists.
+
+ * slime.el (slime-space): First insert the space, then obtain
+ information.
+ (slime-fontify-string): Also handle argument highlights.
+ (slime-enclosing-operator-names): As a secondary value, return a
+ list of the indices of the arguments to the nested operator.
+ (slime-contextual-completions): Use changed interface of
+ slime-enclosing-operator-names.
+ (slime-function-called-at-point): Removed.
+ (slime-function-called-at-point/line): Removed.
+ (slime-autodoc-thing-at-point): New.
+ (slime-autodoc): Re-implement with slime-enclosing-operator-names
+ instead of slime-function-called-at-point.
+ (slime-echo-arglist): Pass the argument indices to
+ arglist-for-echo-area.
+ (slime-autodoc-message-ok-p): Autodoc is also OK in REPL buffers.
+
+ * swank.lisp (arglist-for-echo-area): New keyword argument
+ arg-indices.
+ (arglist-to-string): New keyword argument highlight.
+ (format-arglist-for-echo-area): Likewise.
+
+2006-03-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-goto-location-buffer): Avoid calling the
+ expensive function find-file-noselect when we are already in the
+ right buffer.
+
+ * swank.lisp (arglist-for-echo-area): Add keyword argument
+ print-right-margin.
+ (arglist-to-string, format-arglist-for-echo-area): Likewise.
+ * slime.el (slime-autodoc): Use it here to make use of the whole
+ width of the echo area for arglist display.
+
+2006-03-16 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-allegro.lisp (inspect-for-emacs): Fix typo.
+
+2006-03-16 Gary King <gwking(a)metabang.com>
+
+ * swank-loader.lisp (lisp-version-string): Modified swank-loader
+ so that Allegro's alisp and mlisp programs get different
+ locations. Otherwise mlisp complains about alisp's files.
+
+2006-03-16 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-to-lisp-filename): Call expand-file-name before
+ passing the filename to the to-lisp function.
+
+2006-03-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-system-history): New variable.
+ (slime-read-system-name): Use a separate history list for ASDF
+ system names.
+ (slime-note-counts-message): New variable.
+ (slime-show-note-counts): Store the note counts message for later use.
+ (slime-highlight-notes, slime-list-compiler-notes): Show a
+ progress message, keeping note counts visible.
+ (slime-find-buffer-package): Handle IN-PACKAGE forms that appear
+ in SWIG/Allegro CL wrappers.
+
+ * swank-allegro.lisp (compile-from-temp-file): Suppress Allegro's
+ redefinition warnings; they are pointless when we are compiling
+ via a temporary file.
+ (profile-report): Implement.
+
+2006-03-06 Nathan Bird <nathan(a)acceleration.net>
+
+ * slime.el (slime-create-filename-translator): use the tramp
+ methods for dissecting and building filenames.
+
+2006-03-04 Wojciech Kaczmarek <wojtekk(a)kofeina.net>
+
+ * slime.el (slime-filename-translations): Typo in example.
+ (slime-create-filename-translator): Typo in generated lambdas.
+
+2006-03-03 Marco Baringer <mb(a)bese.it>
+
+ Allow per-host (per machine-instance actually) filename
+ translation functions.
+
+ * slime.el (slime-translate-to-lisp-filename-function): removed.
+ (slime-translate-from-lisp-filename-function): removed.
+ (slime-filename-translations): New variable.
+ (slime-to-lisp-filename): Rewrote to search through available
+ transalations.
+ (slime-from-lisp-filename): idem.
+ (slime-create-filename-translator): New function.
+ (slime-add-filename-translation): New function.
+
+2006-02-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-eval-macroexpand-inplace): Indent the inserted
+ macroexpansion.
+
+2006-02-27 Marco Baringer <mb(a)bese.it>
+
+ Provide functions for performing macroexpansion inplace, use these
+ functions in the *SLIME macroexpansion* buffer.
+
+ * slime.el (slime-macroexpansion-minor-mode): Attempt to map
+ -inplace functions to the same keys as their regular contureparts
+ in slime-mode-map.
+ (slime-eval-macroexpand-inplace): New function.
+ (slime-macroexpand-1-inplace): New function.
+ (slime-macroexpand-all-inplace): New function.
+ * doc/slime.texi: Document new macroexpansion mode.
+
+2006-02-26 Douglas Crosher <dcrosher(a)common-lisp.net>
+ * swank-scl.lisp: (ext:stream-read-chars): Correct the updating of
+ the buffer index. Fixes slime input stream problems.
+
+2006-02-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-loader.lisp (default-fasl-directory): Previously we return
+ only the directory-namestring which breaks SCL, because it loses
+ the host and device components. Return the complete pathname
+ instead. Patch by Douglas Crosher.
+
+ * slime.el (slime-lisp-host): New variable. Replace all references
+ to "127.0.0.1" with the variable.
+
+2006-02-25 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-backend.lisp (operate-on-system): symbol case fix for
+ SCL's lowercase mode.
+
+ * swak.lisp (setup-stream-indirection)
+ (globally-redirect-io-to-connection)
+ (revert-global-io-redirection): symbol case fixes.
+
+ * swank-scl.lisp: (inspect-for-emacs): Fixes for the inspect
+ standard-objects, and inspect array. Plus misc symbol case fixes.
+
+2006-02-22 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-send-input): Don't include the final
+ newline in the slime-repl-input-face overlay, thus avoid showing the
+ "Evaluation aborted" message in boldface. Don't set non-existent
+ "rear-nonsticky" overlay property; overlay stickiness is
+ controlled by make-overlay arguments.
+
+2006-02-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Use argument list information to complete keywords contextually.
+ Example: (find 1 '(1 2 3) :s <M-TAB> --completes--> :start
+ rather than suggesting all ever-interned keywords starting with ":s".
+
+ * slime.el (slime-complete-keywords-contextually): New
+ customizable variable.
+ (slime-enclosing-operator-names): New optional argument
+ max-levels.
+ (slime-completions-for-keyword): New.
+ (slime-contextual-completions): New.
+ (slime-expand-abbreviations-and-complete): Use it instead of
+ slime-completions.
+
+ * swank.lisp (operator-designator-to-form): New, factored out from
+ arglist-for-echo-area.
+ (arglist-for-echo-area): Use it here.
+ (completions-for-keyword): New.
+ (find-matching-symbols-in-list): New.
+
+2006-02-19 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-expand-abbreviations-and-complete): Scroll the
+ completions buffer if the TAB key is pressed another time, like
+ Emacs minibuffer completion does.
+
+2006-02-18 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-macroexpansion-minor-mode): New minor mode for
+ macroexpansion buffer. Exactly like slime-temp-buffer-mode but
+ with slime-macroexpand-again bound to "g".
+ (*slime-eval-macroexpand-expression*): New variable. introduced
+ for slime-macroexpand-again, used by slime-eval-macroexpand as
+ well.
+ (slime-eval-macroexpand): Added optional string argument which
+ defaults to (slime-sexp-at-point-or-error).
+ (slime-macroexpand-again): New function, redoes the last
+ macroexpansion.
+ (slime-sexp-at-point-or-error): New function. Like
+ slime-sexp-at-point but signals an error when slime-sexp-at-point
+ would return nil.
+ * swank-openmcl.lisp (swank-mop:compute-applicable-methods-using-classes):
+ Implement.
+
+2006-02-16 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * sbcl-pprint-patch.lisp: New file, adds the annotations feature
+ to the SBCL pretty printer. This is needed for sending
+ presentations through pretty-printing streams.
+ * present.lisp [sbcl]: Load it here.
+ (slime-stream-p, write-annotation) [sbcl]: Handle pretty-streams.
+
+2006-02-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp, swank-lispworks.lisp (inspect-for-emacs):
+ Use the backend specific method to inspect standard-objects
+ because {slot-boundp,slot-value}-using-class don't conform to the
+ MOP spec in LW and ACL.
+
+ * swank.lisp (macro-indentation): Don't count '&optional as
+ argument.
+
+ * swank-loader.lisp (default-fasl-directory): Include the SLIME
+ version.
+ (slime-version-string): New.
+
+2006-02-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Show enriched arglists for DEFMETHOD in the echo area when the
+ user types SPC after the generic function name.
+
+ * swank.lisp (arglist-to-template-string): Unused, removed.
+ (extra-keywords): Indicate which part of the actual arglist was
+ used to determine the extra keywords. For MAKE-INSTANCE, don't
+ signal an error if the class does not exist.
+ (enrich-decoded-arglist-with-extra-keywords): Indicate which part
+ of the actual arglist was used to determine the extra keywords,
+ and whether any extra keywords were added.
+ (form-completion): Generalize to handle display of enriched formal
+ arglists.
+ (read-incomplete-form-from-string): New, factored out from
+ complete-form. Handle end-of-file.
+ (complete-form): Use it here.
+ (format-arglist-for-echo-area): Use form-completion, so as to
+ show enriched formal arglists for MAKE-INSTANCE and DEFMETHOD
+ calls.
+ (arglist-for-echo-area): Handle MAKE-INSTANCE and DEFMETHOD
+ calls.
+
+ * slime.el (slime-enclosing-operator-names): Represent
+ MAKE-INSTANCE calls by (:make-instance "CLASS-NAME"), handle
+ DEFMETHOD too.
+
+2006-02-05 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-complete-form): Indent the inserted template.
+
+2006-02-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-fontify-string): New.
+ (slime-echo-arglist, slime-arglist, slime-autodoc): Use it here to
+ fontify echo-area arglists.
+
+2006-02-02 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp: Added imports for slot-boundp-using-class,
+ slot-value-using-class and finalize-inheritance.
+
+2006-02-01 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-abcl.lisp: define with-compilation-hooks (= funcall for now), so that you can do slime-oos
+
+2006-01-30 Ian Eslick <eslick(a)csail.mit.edu>
+
+ Show slot values for metaclasses that override the default storage
+ locations for objects slots (i.e. where the default slot-boundp
+ returns nil) in the inspector.
+
+ * swank.lisp (inspect-for-emacs standard-object): Use
+ slot-value-using-class and slot-boundp-using-class.
+
+ * swank-backend.lisp: Add slot-value-using-class and
+ slot-boundp-using-class to the swank-mop package.
+
+2006-01-26 Lu�s Oliveira <loliveira(a)common-lisp.net>
+
+ * slime.el (slime-enclosing-operator-names): detect make-instance
+ forms and collect the class-name argument if it exists and is a
+ quoted symbol.
+
+ * swank.lisp (arglist-for-echo-area): handle pairs of of the form
+ ("make-instance" . "<class-name>") by passing them to
+ format-initargs-and-initforms-for-echo-area.
+ (class-initargs-and-iniforms): New function.
+ (format-initargs-and-initforms-for-echo-area): New function.
+
+2006-01-20 M�sz�ros Levente <melevy(a)freemail.hu>
+
+ * swank-sbcl.lisp (restart-frame): Provide an implementation even
+ if it doesn't quite do what it's supposed to do.
+
+2006-01-19 Helmut Eller <heller(a)common-lisp.net>
+
+ Return to the previous loading strategy: load everything when
+ swank-loader is loaded. It's just to convenient to give that up.
+ To customize the fasl directories, the new variable
+ swank-loader:*fasl-directory* can be set before loading
+ swank-loader.
+
+ * swank-loader.lisp (*fasl-directory*, *source-directory*): New
+ variables.
+ (load-swank): Call it during loading.
+
+2006-01-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-compile-defun): If point was at the opening
+ paren we wrongly used the preceding toplevel form. Fix it.
+ Reported by Chisheng Huang and Liam M. Healy.
+
+ * swank.lisp (spawn-threads-for-connection): Fix a race condition:
+ Don't accept input before all threads are ready.
+
+ Make the fasl directory customizable: load-swank must now be
+ called explicitly so that we can supply the fasl dir as argument.
+
+ * swank-loader.lisp (load-swank): New entry point.
+
+2006-01-14 Andreas Fuchs <asf(a)boinkor.net>
+
+ * slime.el (slime-selector ?r): Call slime instead of slime-start
+ to pick up the usual defaults.
+
+2005-12-31 Harald Hanche-Olsen <hanche(a)math.ntnu.no>
+
+ * slime.el (slime-open-stream-to-lisp): Inherit the
+ process-coding-system from the current connection.
+
+2005-12-27 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-abcl. (backtrace-as-list-ignoring-swank-calls): remove the
+ swank calls from the backtrace to make it easier to use.
+ (frame-locals): Fix a typo that caused entry into the debugger if
+ you tried to look at frame locals. Now you don't error out, but
+ you still don't see frame locals because I don't know how to get
+ them :(
+
+2005-12-27 Helmut Eller <heller(a)common-lisp.net>
+
+ Keep a history of protocol events for better bug reports.
+
+ * swank.lisp (log-event): Record the event in the history buffer.
+ (*event-history*): Buffer for events.
+ (dump-event-history): New function.
+ (close-connection): Escape non-ascii strings and include the event
+ history in the error message.
+
+2005-12-22 Helmut Eller <heller(a)common-lisp.net>
+
+ Make highlighting of modified text a minor mode. Also use
+ after-change-functions instead of rebinding all self-inserting
+ keys.
+
+ * slime.el (slime-highlight-edits-mode): New minor mode.
+ (slime-self-insert-command): Deleted.
+ (slime-before-compile-functions): New hook to decouple edit
+ highlighting from compilation.
+ (slime-highlight-edits-face): Renamed from slime-display-edit-face.
+
+2005-12-20 Marco Baringer <mb(a)bese.it>
+
+ When inspecting classes, methods and generic functions show all
+ the slots in the case that what we're inspecting is a subclass of
+ the standard class and has extra user defined slots.
+
+ * swank.lisp (all-slots-for-inspector): New function.
+ (inspect-for-emacs): Use all-slots-for-inspector.
+
+2005-12-19 Peter Seibel <peter(a)gigamonkeys.com>
+
+ * slime.el (slime-self-insert-command): Got rid of message about
+ setting up face and skipping edit-hilights when in a comment.
+
+2005-12-18 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * slime.el (slime-mode-hook): Bind simple characters to
+ slime-self-insert-command only if there was no previous local
+ binding, and the major mode is _not_ slime-repl-mode. This
+ restores keybindings of slime-xref-mode and prevents us from
+ stomping on user bindings. The hilighting also makes no sense in
+ the REPL.
+
+2005-12-16 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * slime.el (slime-selector-method: ?r): If no connection offer to
+ start Slime.
+
+ * swank.lisp (to-string): Handle errors from printing objects.
+ Among other things makes the inspector more robust in the face of
+ objects with unbound slots and print-methods that fail to cope.
+
+2005-12-16 William Bland <doctorbill.news(a)gmail.com>
+
+ Added hilighting of tetx which has been edited but not yet
+ compilied.
+
+ * slime.el (slime-display-edit-hilights): New variable.
+ (slime-display-edit-face): New face.
+ (slime-compile-file, slime-compile-defun, slime-compile-region):
+ Remove edits overlay.
+ (slime-remove-edits): New function.
+ (slime-self-insert-command): New function.
+ (slime-mode-hook): Rebind simple characters to
+ slime-self-insert-command.
+
+2005-12-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-allegro.lisp (find-definition-in-file)
+ (find-fspec-location, fspec-definition-locations): Allegro CL
+ properly records all definitions made by arbitrary macros whose
+ names start with "def". Use excl::find-source-file and
+ scm:find-definition-in-definition-group (rather than
+ scm:find-definition-in-file) to find them.
+
+ * slime.el (slime-load-file): Change the default to be the buffer
+ file name with extension. This is more convenient for files like
+ .asd files that do not have the default source file extension.
+ (slime-save-some-lisp-buffers, slime-update-modeline-package):
+ Handle all files with major mode in slime-lisp-modes, not just
+ lisp-mode.
+
+2005-12-06 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (function-source-location,
+ safe-function-source-location): Oops, define these functions also
+ for the >0.9.6 case. Fixes broken sldb-show-source on SBCL 0.9.7.
+
+2005-12-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-find-coding-system): Use check-coding-system
+ only if it's actually fbound.
+
+2005-11-22 Marco Monteiro <masmxx(a)gmail.com>
+
+ * slime.el (slime-connect): Use slime-net-coding system if the
+ optional arg coding-system was not supplied.
+
+2005-11-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-compile-file): Call 'check-parens before
+ compiling.
+ (slime-compile-file): Call 'check-parens before compiling.
+ (slime-find-coding-system): Return nil if the coding system
+ isn'tvalid instead of singalling an error.
+ (slime-repl-history-file-coding-system): Use
+ slime-find-coding-system to find the default.
+
+ * swank-cmucl.lisp (accept-connection): Remove fd-handlers if the
+ encoding isn't iso-latin-1.
+
+2005-11-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start): Don't set slime-net-coding-system ..
+ (slime-read-port-and-connect): .. read it from the inferior lisp args.
+ (slime-connect): Take the coding-system as third argument.
+ (slime-repl-history-file-coding-system): New user option.
+ (slime-repl-safe-save-merged-history): New function. Use it in
+ hooks so that bad coding systems don't stop us from exiting.
+ (slime-repl-save-history): Include the coding-system which was
+ used to save the buffer.
+ (repl-shoctut change-package): Add alias ,in and ,in-package.
+ (slime-eval-macroexpand): Error out early if there's no sexp at
+ point.
+ (slime-compiler-macroexpand): New command.
+ (slime-inspector-pprint): New command.
+
+ * swank-cmucl.lisp (inspect-for-emacs): Add support for
+ funcallable instances.
+
+ * swank.lisp (pprint-inspector-part, swank-compiler-macroexpand): New.
+
+ * swank-backend.lisp (compiler-macroexpand)
+ (compiler-macroexpand-1): New functions.
+
+2005-11-14 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl.lisp (accept-connection): handle the :buffering argument.
+
+2005-11-13 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp: (accept-connection): New argument: buffering.
+
+2005-11-13 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp: Steal auto-flush stuff from swank-sbcl.lisp
+
+2005-11-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*dedicated-output-stream-buffering*): New variable
+ to customize the buffering scheme. For single-threaded Lisps we
+ disable buffering because lazy programmers forget to call
+ finish-output.
+ (open-dedicated-output-stream): Use it.
+
+ * swank-backend.lisp, swank-allegro.lisp, swank-lispworks.lisp,
+ swank-openmcl.lisp, swank-cmucl.lisp, swank-sbcl.lisp,
+ swank-clisp.lisp, swank-abcl.lisp, swank-corman.lisp,
+ swank-ecl.lisp (accept-connection): New argument: buffering.
+
+ * slime.el (slime-repl-save-history): When the history exceeds
+ slime-repl-history-size remove the old not the new entries.
+ Some renaming:
+ slime-repl-read-history -> slime-repl-load-history,
+ slime-repl-read-history-internal -> slime-repl-read-history.
+ (slime-eval-macroexpand): Call font-lock-fontify-buffer
+ explicitly, because with certain Emacs versions the buffer doesn't
+ get fontified immediately.
+
+2005-11-07 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-eval-macroexpand): Use lisp-mode (and
+ font-lock-mode) when dispaying the expansion. Suggested by Jan
+ Rychter.
+
+ * swank-source-path-parser.lisp (make-source-recording-readtable):
+ Suppress the #. reader-macro.
+
+2005-11-06 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (find-definitions, make-source-location-specification
+ make-definition-source-location, source-hint-snippet): As of
+ SBCL 0.9.6.25 SB-INTROSPECT has better support for finding
+ source locations. Use as much of it in swank-sbcl as possible.
+ (Original version left reader-conditionalized for older SBCLs).
+
+2005-11-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (connection-info): Docfix.
+
+ * slime.el (slime-set-connection-info): Generate a new connection
+ name only if the implementation-name and the inferior-lisp-name
+ are different.
+
+2005-10-31 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start, slime-lookup-lisp-implementation)
+ (slime-set-connection-info): Add a :name property for the
+ implementation and use it to derive the connection-name.
+ (slime-lisp-implementation-name): Renamed from
+ slime-lisp-implementation-type-name.
+
+ * swank.lisp (simple-serve-requests): Add an extra abort restart.
+ (connection-info): Rename :type-name to :name.
+
+2005-10-30 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp (inspect-for-emacs): Track mop changes in ABCL.
+
+2005-10-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-eval): Ensure that the connection is open before
+ waiting for input.
+
+ * swank.lisp (simple-serve-requests): Close the connection at the
+ end.
+
+2005-10-23 Harald Hanche-Olsen <hanche(a)math.ntnu.no>
+
+ * slime.el (slime-init-keymaps): Use vectors when defining keys,
+ because e.g. (define-key (string ?\C-c) ...) doesn't work in the
+ emacs-unicode-2 branch.
+
+2005-10-23 Stefan Kamphausen <skampi(a)gmx.net>
+
+ * slime.el (slime-repl-history-size, slime-repl-history-file): Use
+ defcustom to declare the variables.
+
+2005-10-23 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-backend.lisp (install-debugger-globally): new interface
+ function
+
+ * swank.lisp (install-debugger): call install-debugger-globally
+
+ * swank-sbcl.lisp (install-debugger-globally): set
+ sb-ext:*invoke-debugger-hook* too
+
+2005-10-23 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (make-stream-interactive): Spawn a thread to
+ flush interactive streams in reasonably short intervals.
+ Remove the old backward-compatible threading implementation.
+
+ * swank.lisp (package-string-for-prompt): Respect *print-case*.
+
+2005-10-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start-swank-server): Avoid comint-send-input
+ here as it seems to trigger a bug in ansi-color-for-commit-mode.
+
+2005-10-18 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank.lisp (canonical-package-nickname): always return the
+ package name as a STRING if found. This restores the printing of
+ package names as strings.
+
+2005-10-17 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (eval-in-emacs): Instead of taking a string and
+ attempting to parse it emacs side the function now takes a form
+ and converts it to a string internally. This should allow users of
+ the function to not have to worry about quoting issues and emacs'
+ different printed represenation for, among other things,
+ characters.
+ (process-form-for-emacs): New function. Converts a list into a
+ string for passing to emacs.
+
+ * slime.el (slime-eval-for-lisp): New API. This function now takes
+ a single string, representing the form to evaluate, and uses
+ emacs' read function to convert it into a form before eval'ing it.
+ (slime-dispatch-event): The :eval event now passes a single
+ string (instead of a string and something looking kind of like a
+ form).
+
+2005-10-15 Douglas Crosher <dcrosher(a)common-lisp.net>
+
+ * swank-scl.lisp: Support for Scieneer Common Lisp.
+
+ * swank-backend.lisp (*gray-stream-symbols*) Scieneer Common Lisp
+ implements stream-line-length.
+
+ * swank-loader.lisp: Support for Scieneer Common Lisp:
+ (*sysdep-pathnames*) use swank-scl.
+ (*impl ementation-features*) add :scl.
+ (*os-features*) add :hpux.
+ (*architecture-features*) add :amd64, :i686, :i486, :sparc64, :sparc,
+ :hppa64, and :hppa.
+
+ * swank.lisp: (*canonical-package-nicknames*) use lowercase
+ symbols to name the packages. This supports CL implementations
+ with lowercase default symbol names, such as Scieneer Common Lisp,
+ while still being compatible with ANSI-CL.
+
+2005-10-11 Stefan Kamphausen <skampi(a)gmx.net>
+
+ * slime.el: Persistent REPL history. The history from REPL
+ buffers is now saved to the file ~/.slime-history.eld. The file
+ is read on startup and saved when a REPL buffer gets killed or
+ when Emacs exits. There are also commands to save or read the
+ history file.
+ (slime-repl-save-merged-history, slime-repl-merge-histories)
+ (slime-repl-read-history, slime-repl-save-history): New functions.
+ (slime-repl-history-file, slime-repl-history-size): New vars.
+ (slime-repl-mode): Add hooks to load and save the history.
+
+2005-10-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-read-interactive-args): Split the string
+ inferior-lisp-program to get the values for :program and
+ :program-args. Also let slime-lisp-implementations take
+ precedence if non-nil.
+ (slime-lisp-implementations): Renamed from
+ slime-registered-lisp-implementations.
+
+ * swank.lisp (force-user-output): There seems to be a bug in
+ Allegro's two-way-streams. As a workaround we use force-output for
+ the user-io stream. (finish-output *debug-io*) still triggers the
+ bug.
+
+2005-10-10 Svein Ove Aas <svein.ove(a)aas.no>
+
+ * swank-allegro.lisp (find-external-format): Translate :utf-8-unix
+ to :utf8, which Allegro 7.0 understands.
+
+2005-10-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime, slime-start): Introduce a separate function for
+ the non-interactive case. `slime-start' takes lots of keyword
+ arguments and `slime' is reserved for interactive use.
+ (slime-read-interactive-args): New function.
+ (slime-maybe-start-lisp, slime-inferior-lisp)
+ (slime-start-swank-server): Pass all arguments needed to start
+ the subprocess as a property list. Also store this list in a
+ buffer-local var in the inferior-lisp buffer, so that we can
+ cleanly restart the process.
+ (slime-registered-lisp-implementations): Change the format and
+ document it. M-- M-x slime can now be used select a registered
+ implementation.
+ (slime-symbolic-lisp-name): Deleted. And updated all the functions
+ which passed it along.
+ (slime-set-connection-info): Use the new format.
+ (slime-output-buffer): Don't re-initialize buffer-local variables
+ if the buffer already exists. This saves the history. From Juho
+ Snellman.
+
+ * swank-cmucl.lisp (sis/in): Use finish-output instead of
+ force-output.
+
+ * swank.lisp (connection-info): Include the initial package and
+ a more self-descriptive format.
+
+2005-10-01 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-backend (*gray-stream-symbols*): Add :STREAM-LINE-LENGTH
+ to *GRAY-STREAM-SYMBOLS* on implementations that support this
+ extension to gray streams. Reported by Matthew D Swank.
+
+2005-09-29 Luke Gorrie <luke(a)synap.se>
+
+ * swank-scheme48: Removed due to excessive whining.
+
+2005-09-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-multiprocessing): Deleted. No longer needed.
+ (slime-init-command): Updated accordingly.
+ (slime-current-package): Add a special case for Scheme.
+ (slime-simple-completions, slime-apropos): Quote the package,
+ because in can be a plain symbol in Scheme.
+ (slime-inspector-reinspect): Use a proper defslimefun.
+
+ * swank.lisp (inspector-reinspect): New function.
+ (start-server): Call initialize-multiprocessing before starting
+ the server and startup-idle-and-top-level-loops afterwards.
+ Calling startup-idle-and-top-level-loops here shouldn't be a
+ problem because start-server is only invoked at startup via stdin.
+
+ * swank-scheme48/source-location.scm: New file. For M-.
+ * swank-scheme48/module.scm (list-all-package): New function.
+ * swank-scheme48/interfaces.scm (module-control-interface): Export it.
+ * swank-scheme48/inspector.scm: Add methods for records and hashtables.
+ (swank:arglist-for-echo-area): Implement it. Only works for
+ functions with enough debug-data (ie. only user-defined functions).
+ * swank-scheme48/completion.scm: New file.
+ (swank:simple-completions, swank:apropos-list-for-emacs): Implemented.
+ * swank-scheme48/load.scm, swank-scheme48/defrectypeX.scm: Renamed
+ the file from defrectype*.scm
+ * swank-scheme48/packages.scm (swank-general-rpc): Don't use
+ posix-process because it doesn't work on Windows, and we don't need
+ it for a mulithreaded server.
+
+2005-09-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-backend.lisp (*gray-stream-symbols*): Collect the needed
+ symbols here, so that we don't need to mention them in every
+ backend.
+ (import-from). New function.
+
+ * swank-sbcl.lisp, swank-allegro.lisp, swank-lispworks.lisp,
+ swank-openmcl.lisp, swank-ecl.lisp: Use *gray-stream-symbols* when
+ importing the needed symbols.
+
+ * swank-gray.lisp (stream-fresh-line): Define a method, so that
+ Allegro passes our tests.
+
+2005-09-21 Aleksandar Bakic <a_bakic(a)yahoo.com>
+
+ * swank.lisp (accept-authenticated-connection): Minor fix. Ensure
+ that the decoded message is a string before calling string= on it.
+
+2005-09-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-setup-command-hooks): Make
+ after-change-functions a buffer-local variable; it's by default
+ global in XEmacs.
+
+ * swank.lisp (throw-to-toplevel): Invoke the `abort-restart'
+ request instead of throwing to the `slime-toplevel' catch tag.
+ (handle-request): Rename the restart from abort to abort-request.
+ (call-with-connection): Remove the slime-toplevel catch tag
+ because with-connection is used in far to many places which aren't
+ at "toplevel".
+
+ * present.lisp (presentation-start, presentation-end): Use
+ finish-output instead of force-output.
+
+ * swank-gray.lisp, swank-cmucl.lisp: Improve stream efficiency by
+ buffering more output. stream-force-output simply does nothing, if
+ the output buffer was flushed less than 200 millisecons before.
+ stream-finish-output can still be used to really flush the buffer.
+ (slime-output-stream): New slot last-flush-time.
+ (stream-finish-output): New function. Do what stream-force-output
+ did previously.
+ (stream-force-output): Buffer more output.
+
+ * slime.el (slime-process-available-input): Oops, don't start a
+ timer for every event.
+ (slime-write-string): Renamed from slime-output-string.
+ (slime-dispatch-event): Rename :read-output to :write-string.
+ (slime-io-speed-test): New command.
+ (slime-open-stream-to-lisp): Fix parens. The coding system should
+ also be set if presentations are disabled.
+
+ * swank.lisp (make-output-function): Rename :read-output to
+ :write-string.
+ (eval-for-emacs, interactive-eval, eval-region): Use finish-output
+ not force-output.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp, swank-allegro.lisp,
+ swank-lispworks: Import `stream-finish-output'.
+
+ * swank-scheme48/io.scm (empty-swank-output-buffer): Rename
+ :read-output to :write-string.
+
+ * swank-scheme48/load.scm (slime48-start): Fix '() vs. #f bug.
+
+2005-09-19 Luke Gorrie <luke(a)synap.se>
+
+ * nregex.lisp: Released into the public domain by Lawrence E. Freil.
+
+2005-09-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime48): New command.
+
+2005-09-19 Taylor Campbell <campbell(a)mumble.net>
+
+ * swank-scheme48/: New backend.
+
+2005-09-18 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * bridge.el: cl is required at macro expansion time (because of
+ `block'). Reported by Matthew D Swank.
+
+2005-09-18 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp: Move presentation menu protocol here from present.lisp.
+
+2005-09-15 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el (slime-repl-return) don't copy presentation to input if
+ already in input area.
+
+2005-09-15 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-clisp.lisp (compute-backtrace): Include only "function
+ frames" in the backtrace. I hope that makes some sense.
+ (sldb-backtrace, function-frame-p): New functions.
+ (*sldb-backtrace*, call-with-debugging-environment, nth-frame):
+ Compute and remember the backtrace when entering the debugger.
+ (arglist): If the function has a function-lambda-expression, fetch
+ the arglist from there.
+ (find-encoding): Use strings instead of 'charset:foo symbols to
+ avoid compile time problems if the charset is not available.
+ Suggested by Vaucher Laurent.
+
+ * swank.lisp (eval-in-emacs): Fix a race condition which occurred
+ with sigio.
+ (*echo-area-prefix*): New variable.
+
+ * slime.el (slime-process-available-input): Simplify it a bit and
+ make it easier to debug read errors.
+ (slime-net-close): Don't kill the buffer if the new optional arg
+ `debug' is true.
+ (slime-run-when-idle): Accept arguments for the function.
+ (slime-init-connection-state): Close over the proc variable. It
+ was lost when the async evaluation returned.
+ (slime-output-buffer, slime-connection-output-buffer): Make
+ slime-output-buffer faster by keeping the buffer in a connection
+ variable.
+ (slime-restart-inferior-lisp-aux, slime-quit-lisp): Disable the
+ process filter to avoid errors in XEmacs.
+
+2005-09-14 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (slime-menu-choices-for-presentation), (slime-presentation-menu)
+ Fix loss after refactoring. xemacs can't handle lambda forms in
+ the menu spec given to x-popup-menu, only symbols, so save the
+ actions in a hash table keyed by a gensym, give x-popup-menu the
+ gensym and then call the gensym. Haven't checked that it actually
+ works in xemacs because my xemacs is hosed in os x Tiger. Could
+ someone let me know...
+
+ * swank.lisp (inspect-factor-more-action)
+ rename (inspect-show-more-action) Prompt before reading how many
+ more. Would be nicer to prompt in the minibuffer...
+
+2005-09-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-expression): Remove handling of
+ cons presentation-ids.
+
+2005-09-13 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (defcustom slime-ed-use-dedicated-frame ... vs defvar
+
+ (defcustom slime-when-complete-filename-expand: Use
+ comint-replace-by-expanded-filename instead of
+ comint-dynamic-complete-as-filename to complete file names
+
+ * swank.lisp (run-repl-eval-hooks .. finally (return vs no return
+
+ inspector-call-nth-action Allow second value :replace for inspector actions
+
+ (defvar *slime-inspect-contents-limit* default nil. How many elements of
+ a hash table or array to show by default. If table has more than
+ this then offer actions to view more. Set to nil for no limit. Probably should
+ set default to reasonable value - I like 200.
+
+ (inspect-for-emacs ((ht hash-table) inspector)) - banner line is hash table object.
+ Respect *slime-inspect-contents-limit*
+
+ (defmethod inspect-for-emacs ((array array) inspector)
+ Respect *slime-inspect-contents-limit*
+
+ * swank-openmcl.lisp inspector for closures shows closed-over
+ values. To be fixed: inspector-princ needs to be loaded earlier
+ since swank package not available when compiling
+
+2005-09-13 Helmut Eller <heller(a)common-lisp.net>
+
+ * present.lisp (menu-choices-for-presentation-id): Use
+ lookup-presented-object secondary return value instead of
+ *not-present*.
+ (execute-menu-choice-for-presentation-id, presenting-object-1):
+ Remove references to *can-print-presentation*.
+
+ * slime.el (slime-current-output-id): Remove this ugly klugde.
+ (slime-repl-insert-result): New function. Handle the presentations
+ and other special cases cleaner.
+ (slime-repl-insert-prompt): Use it. The `result' arg is now a
+ structured list; update callers accordingly.
+ (slime-repl-return): Make the prefix arg work again.
+ (package-updating): The result of swank::listener-eval changed a
+ bit. Update the test.
+
+ Remove some unnecessary uses of `defun*' and reindent it to 80
+ columns.
+
+ * swank.lisp: Simplify the object <-> presentation-id mapping.
+ (save-presented-object): Remove the optional `id' arg.
+ (lookup-presented-object): Id should be a fixnum not some cons
+ with fuzzy/non-documented meaning. Use the secondary return value
+ to test for absence of the id. Update callers accordingly.
+ (*not-present*): Deleted.
+
+ Remove the repl result special cases, let the general presentation
+ machinery handle it.
+ (*last-repl-result-id*, add-repl-result, *current-id*)
+ (clear-last-repl-result): Deleted.
+ (listener-eval): Don't *current-id* to tag result values.
+
+ (*can-print-presentation*): Deleted. Nobody quite knows whether
+ it's still needed so let just try without it. Updated referrers
+ accordingly.
+
+ (eval-region, run-repl-eval-hooks): Move the eval hook stuff to
+ a separate function.
+
+ * swank-loader.lisp (lisp-version-string)[cmu]: Replace spaces
+ with underscores.
+
+2005-09-12 NIIMI Satoshi <sa2c(a)sa2c.net>
+
+ * swank.lisp, slime.el, swank-clisp.lisp, swank-sbcl.lisp: add
+ EUC-JP as coding system. This patch eliminates the requirement of
+ Mule-UCS to use Japanese characters. (Nice for pre-22 Emacs
+ users.)
+
+2005-09-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-enable-evaluate-in-emacs): Resurrected.
+ (slime-dispatch-event): Respect slime-enable-evaluate-in-emacs for
+ messages :eval-no-wait and :eval.
+
+2005-09-09 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el (slime-choose-overlay-region). Don't try to overlay a
+ note if location is nil.
+
+2005-09-08 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * bridge.el Fix bug in bridge filter where a bridge message which
+ straddled a packet would be mishandled. Sometimes this would
+ result in spurious bridge message text being inserted with the
+ presentation and the presentation not being sensitive. In other
+ cases there would be an actual error. Introduce bridge-leftovers
+ to save the last, unfinished bit for the next call, and prepend it
+ before processing a chuunk. Also, fix the parentheses so that the
+ unwind protect cleanup forms are actually in the cleanup section.
+ In openmcl, where apparently communication with slime is done in
+ 2k chunks, you can trigger the bug with something like this:
+ (swank::presenting-object 'foo t
+ (dotimes (i 2040) (write-char #\:)))
+
+ * swank-openmcl.lisp (handle-compiler-warning). Don't create a
+ location if the condition doesn't have a filename. If it does,
+ make sure you pass a string rather than a pathname object
+ otherwise you get a net-read error
+
+2005-09-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * present.lisp (menu-choices-for-presentation): The
+ Inspect/Describe/Copy items are now provided from the Emacs side.
+ Implement all pathname menu items without having Emacs evaluate a
+ form. Fix for Lisps where ".lisp" is parsed as :name ".lisp".
+
+ * slime.el (slime-menu-choices-for-presentation): New function,
+ return a menu with Inspect/Describe/Copy plus the items that come
+ from the menu protocol.
+ (slime-presentation-menu): Security improvement for the
+ presentation menu protocol: Don't eval arbitrary forms coming from
+ the Lisp. Minor cleanup: Use x-popup-menu in the normal Emacs way,
+ associating a command with each menu item.
+
+2005-09-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp (background-message): New function. Forward the
+ call to the front end.
+ (pre-gc-hook, post-gc-hook): Use it.
+ (swank-sym, sending-safe-p): Deleted.
+
+ * swank.lisp (y-or-n-p-in-emacs): Simplify arglist.
+ (evaluate-in-emacs, dispatch-event, send-to-socket-io): Remove
+ evaluate-in-emacs stuff.
+ (to-string): Undo last change. to-string is not to supposed to
+ ignore errors. Bind *print-readably* instead.
+ (background-message): New function.
+ (symbol-external-p): Simplify it a little.
+
+ * slime.el (slime-setup-command-hooks): Add after-change-functions
+ only if presentations are enabled.
+ (slime-dispatch-event, slime-enable-evaluate-in-emacs)
+ (evaluate-in-emacs): Remove evaluate-in-emacs stuff. It was not
+ used and redundant.
+ (slime-save-some-lisp-buffers): Renamed from
+ save-some-lisp-buffers.
+ (slime-choose-overlay-region): Ignore :source-form locations.
+ (slime-choose-overlay-for-sexp): Ignore errors when stepping over
+ forms.
+ (slime-search-method-location, slime-goto-location-position): Move
+ all this regexpery to its own function.
+ (slime-recenter-if-needed, slime-repl-return): Factor some
+ duplicated code into its own function.
+ (slime-presentation-bounds, slime-presentation-around-point)
+ (slime-presentation-around-or-before-point): Minor cleanups.
+
+2005-09-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-ensure-presentation-overlay): New.
+ (slime-add-presentation-properties): Don't add face, mouse-face,
+ keymap text properties. Call slime-ensure-presentation-overlay to
+ implement them via overlays.
+ (slime-remove-presentation-properties): Don't remove these text
+ properties. Delete the right overlay.
+ (slime-after-change-function): Add overlays for presentations if
+ necessary.
+ (slime-copy-presentation-at-point): Don't add face text property.
+ (slime-repl-grab-old-output): Likewise.
+
+2005-08-31 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (to-string): Handle errors during printing of objects.
+
+2005-08-30 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el (slime-mark-presentation-start/end-handler) modify
+ regexp to recognize negative presentation ids to make
+ presenting-object work with bridge mode.
+
+2005-08-30 Luke Gorrie <luke(a)synap.se>
+
+ * present.lisp: Added public domain dedication (OK'd by Alanr and
+ Matthias on the list).
+
+2005-08-29 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-lispworks.lisp (env-internals:confirm-p): Use new function
+ y-or-n-p-in-emacs rather than eval-in-emacs.
+
+ * swank-cmucl.lisp (eval-in-emacs): Removed.
+ (send-to-emacs): New.
+ (pre-gc-hook, post-gc-hook): Use new protocol message
+ :background-message rather than eval-in-emacs.
+
+ * swank.lisp (dispatch-event, send-to-socket-io): Handle new
+ messages :y-or-n-p, :background-message.
+ (y-or-n-p-in-emacs): New function.
+
+ * slime.el (slime-dispatch-event): Handle new messages :y-or-n-p,
+ :background-message.
+ (slime-y-or-n-p): New.
+
+2005-08-29 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (sldb-insert-condition) - Add tooltip for long
+ condition string which otherwise falls off the right of the screen
+ * swank.lisp (list-threads) - thread name might be a symbol - pass
+ the symbol name when that happens
+
+2005-08-29 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp (make-weak-key-hash-table): Remove the
+ implementation; SBCL doesn't actually support weak hash-tables.
+
+2005-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-repl-kill-input): New command.
+ (slime-repl-mode-map): Bind it to C-c C-u, like in comint.
+ (slime-repl-easy-menu): Include it in the REPL menu.
+ (slime-repl-mode-hook): Show the SLIME menu in the REPL too.
+
+ * swank-backend.lisp (make-weak-key-hash-table)
+ (make-weak-value-hash-table): New interfaces.
+ * swank-cmucl.lisp (make-weak-key-hash-table): Implement it.
+ * swank-sbcl.lisp (make-weak-key-hash-table): Implement it.
+ * swank-openmcl.lisp (make-weak-key-hash-table)
+ (make-weak-value-hash-table): Implement it.
+
+ * swank.lisp (*object-to-presentation-id*)
+ (*presentation-id-to-object*): Use new functions
+ make-weak-key-hash-table, make-weak-value-hash-table.
+
+ * slime.el (slime-enable-evaluate-in-emacs): New variable.
+ (evaluate-in-emacs): Security improvement: If
+ slime-enable-evaluate-in-emacs is nil (the default), don't
+ evaluate forms sent by the Lisp.
+
+ * swank.lisp (send-to-socket-io): Handle :evaluate-in-emacs.
+
+2005-08-27 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-menu): When an object is no longer
+ recorded, remove text properties from the presentation.
+
+2005-08-15 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-openmcl.lisp (condition-source-position)
+ ccl::compiler-warning-stream-position is sometimes nil, so placate
+ this function by making it (or .. 0). Wrong but I don't have
+ enough time now to figure out what the right thing is.
+
+
+2005-08-24 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (fuzzy-find-matching-symbols): When completing the
+ string "package:" present a list of all the external symbols in
+ package (completing "package::" lists internal symbols as well).
+ (inspect-for-emacs standard-class): List all the slots in the
+ class (as per standard-object). The previous method of hard coding
+ the slots in the inspector's code made inspecting custom
+ meta-classes useless.
+
+2005-08-24 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank-sbcl.lisp (method-definitions): present qualifiers (if
+ any).
+
+2005-08-23 Taylor R. Campbell <campbell(a)bloodandcoffee.net>
+
+ * slime.el (slime-goto-location-position): Added a second regexp
+ for the :function-name case which matches "(def... ((function-name
+ ..." (with N opening parens preceding the function name). This is
+ to allow scheme48 style function names and definitions.
+
+2005-08-22 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * swank-clisp.lisp (fspec-pathname): Cope with CVS CLISP's
+ (documentation symbol 'sys::file) returning a list. Return either
+ a list of start and end line positions or nil as second value.
+ (fspec-location): Use it. Also, if we have to guess the name of a
+ source file make sure that it actually exists.
+
+ (with-blocked-signals, call-without-interrupts): Don't add
+ :linux to *features* since this changes the return value of
+ unique-directory-name in swank-loader.lisp.
+ Comment out with-blocked-signals.
+
+ Update some comments at the top of the file.
+ State the licence in the same terms as slime.el does.
+
+2005-08-21 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * present.lisp (menu-choices-for-presentation-id): Check against
+ the gensym in *not-present* instead of :non-present.
+
+2005-08-20 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank-sbcl.lisp (preferred-communication-style): guard against
+ non-Linux non-linkage-table platforms (and assume that they won't
+ have dodgy threads) with #+linux.
+
+2005-08-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Enable nested presentations.
+
+ * slime.el (slime-presentation): Remove slots start-p, stop-p.
+ (slime-add-presentation-properties): Use a new text property
+ layout. Also add an overlay to enable nested highlighting.
+ (slime-remove-presentation-properties): New.
+ (slime-presentation-whole-p): Changed interface.
+ (slime-presentations-around-point): New.
+ (slime-same-presentation-p): Removed.
+ (slime-presentation-start-p, slime-presentation-stop-p): New.
+ (slime-presentation-start, slime-presentation-end): Changed to use
+ new text property layout.
+ (slime-presentation-bounds): New.
+ (slime-presentation-around-point): Reimplemented to handle nested
+ presentations.
+ (slime-for-each-presentation-in-region): New.
+ (slime-after-change-function): Use
+ slime-remove-presentation-properties and
+ slime-for-each-presentation-in-region.
+ (slime-copy-presentation-at-point): Complain if no presentation.
+ (slime-repl-insert-prompt): Don't put rear-nonsticky text property.
+ (slime-reify-old-output): Handle nested presentations.
+ (slime-repl-return): Use slime-presentation-around-or-before-point.
+
+ Enable reification of presentations in non-REPL buffers.
+
+ * slime.el (slime-buffer-substring-with-reified-output): New,
+ factored out from slime-repl-current-input.
+ (slime-repl-current-input): Use it here.
+ (slime-last-expression): Use it here.
+
+ (slime-add-presentation-properties): Add text properties
+ modification-hooks et al. to enable self-destruction of incomplete
+ or edited presentations in non-REPL buffers.
+
+2005-08-15 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (slime-goto-location-position) fix so the :method locator
+ regexp so that it can find eql specializers, (setf foo) methods, and to
+ allow (a single) newline between arguments in the arglist.
+
+ * swank-openmcl.lisp (specializer-name) patch from Gary Byers and
+ Bryan O'Conner to fix complaint about certain classes slipping
+ through the etypecase
+
+2005-08-14 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-mark-presentation-end): Really remove the
+ presentation-start entry from the hash table.
+
+ Merge some code from present.lisp, removing code duplication.
+ Minor code clean-up.
+
+ * swank.lisp (*object-to-presentation-id*)
+ (*presentation-id-to-object*, clear-presentation-tables)
+ (*presentation-counter*, lookup-presented-object): Move here from
+ present.lisp.
+ (save-presented-object): Likewise. Assign negative numbers only,
+ so as not to clash with continuation ids.
+
+ * swank.lisp (*repl-results*): Removed.
+
+ * swank.lisp (get-repl-result, clear-repl-results): Use new
+ implementations from present.lisp.
+ (add-repl-result): Likewise, don't take the negative of the id.
+ (*last-repl-result-id*): New variable.
+ (clear-last-repl-result): Use it here.
+
+ * slime.el (slime-repl-insert-prompt): Don't take the negative of
+ the id.
+ (slime-presentation-expression): New, take care to handle
+ arbitrary *read-base* settings.
+ (reify-old-output): Use it here.
+ (slime-read-object): Use it here.
+
+2005-08-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (substring-no-properties): Fix to handle non-zero start
+ argument correctly.
+
+ Patch to remove use of the slime-repl-old-output text property in
+ favor of the slime-repl-presentation text property, in order to
+ simplify the code.
+
+ * slime.el (slime-presentation-whole-p): Generalize to work with
+ strings too.
+ (slime-presentation-start, slime-presentation-end): Likewise.
+ (slime-presentation-around-point): Likewise.
+ (slime-presentation-around-or-before-point): New.
+
+ * slime.el (reify-old-output): Use slime-repl-presentation
+ property and slime-presentation-around-point function rather than
+ slime-repl-old-output property.
+ (slime-repl-return): Use slime-repl-presentation rather than
+ slime-repl-old-output.
+ (slime-repl-grab-old-output): Use
+ slime-presentation-around-or-before-point.
+ (slime-read-object): Use slime-presentation-around-point.
+
+ * slime.el (toplevel): Don't handle slime-repl-old-output text
+ property.
+ (slime-add-presentation-properties): Likewise.
+ (slime-after-change-function): Likewise.
+
+2005-08-12 Yaroslav Kavenchuk <kavenchuk(a)jenty.by>
+
+ * swank-clisp.lisp (fspec-pathname): Use the documentation
+ function instead of accessing clisp internals.
+
+2005-08-11 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (transpose-lists): Fixed it.
+
+2005-08-10 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el move slime-repl-add-to-input-history to
+ slime-repl-send-input so we can see the presentations we copied to
+ input when we reuse history rather than #.(blah...)
+ [Thanks Matthias! - was very busy and just returned to see your
+ changes merged. Most excellent.]
+
+2005-08-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-presentation-around-point): Change interface,
+ return presentation as primary return value.
+ (slime-copy-presentation-at-point): Use
+ slime-presentation-around-point. Copying now also works when the
+ first character is clicked and when the REPL buffer is not current.
+ (slime-presentation-menu): Use slime-presentation-around-point.
+
+2005-08-10 Martin Simmons <martin(a)lispworks.com>
+
+ * swank-lispworks.lisp (defadvice compile-file): Return all values
+ from the real compile-file.
+
+2005-08-10 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (transpose-lists): Replaced with much nicer function
+ by Helmut Eller.
+
+2005-08-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-read-object): Handle ids that are conses.
+ Patch by "Thas" on #lisp.
+
+2005-08-09 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (transpose-lists): Reimplemented without APPLY so we
+ don't have problems with CALL-ARGUMENTS-LIMIT.
+
+2005-08-08 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (undo-in-progress): Define for XEmacs compatibility.
+ Reported by Friedrich Dominicus.
+
+2005-08-07 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Fix for the presentations menu. Reported by Aleksandar Bakic.
+
+ * present.lisp (lookup-presented-object): Handle ids that are
+ conses.
+ (execute-menu-choice-for-presentation-id): Use equal for comparing
+ ids, to handle the cons case.
+ (menu-choices-for-presentation): Quote the presentation id, as it
+ can be a cons.
+ * slime.el (slime-presentation-menu, slime-presentation-menu)
+ (slime-inspect-presented-object): Quote the presentation id.
+
+2005-08-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (form-completion): New generic function, factored out
+ from complete-form.
+ (complete-form): Factor out form-completion.
+ (form-completion): Specialize on defmethod forms to insert arglist
+ of generic function.
+
+ * doc/slime.texi (Programming Helpers): Document C-c C-s,
+ slime-complete-form.
+
+2005-08-04 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Improvements to the presentations feature. Parts of presentations
+ can be copied reliably using all available Emacs facilities (not
+ just kill-ring-save), and they are no longer "semi-readonly" (in
+ the sense that keypresses are silently ignored). Whenever a user
+ attempts to edit a presentation, it now simply turns into plain
+ text (which is indicated by changing the face); this can be
+ undone. Presentations are now also supported if
+ *use-dedicated-output-stream* is nil. It is now possible to
+ access the individual values of multiple-value results. For some
+ systems (Allegro CL and upcoming CMUCL snapshots), presentations
+ can be reliably printed through pretty-printing streams.
+
+ * present.lisp (slime-stream-p) [allegro]: Allow printing
+ presentations through pretty printing streams.
+ [cmu]: Allow printing presentations through pretty printing
+ streams, if CMUCL has annotations support and we are using the
+ bridge-less protocol.
+ [sbcl]: Allow printing presentations through indenting streams.
+
+ * present.lisp (write-annotation): New function.
+ (presentation-record): New structure.
+ (presentation-start, presentation-end): New functions, supporting
+ both bridge protocol and bridge-less protocol.
+ (presenting-object-1): Use them here.
+
+ * present.lisp [sbcl, allegro]: Add printer hooks for unreadable
+ objects and pathnames.
+
+ * swank.lisp (*can-print-presentation*): New variable, moved here
+ from present.lisp.
+ * swank.lisp (interactive-eval, listener-eval, backtrace)
+ (swank-compiler, compile-file-for-emacs, load-file)
+ (init-inspector): Bind *can-print-presentation* to an appropriate
+ value.
+ * present.lisp: Remove code duplication with swank.lisp for the
+ functions above.
+
+ * swank.lisp (encode-message): Don't use the pretty printer for
+ printing the message length.
+
+ * slime.el (slime-dispatch-event): New events :presentation-start,
+ :presentation-end for bridge-less presentation markup.
+ * swank.lisp (dispatch-event, send-to-socket-io): Likewise.
+
+ * swank.lisp (listener-eval): Store the whole values-list with
+ add-repl-result.
+ * slime.el (slime-repl-insert-prompt): Accept a list of strings,
+ representing individual values of a multiple-value result. Mark
+ them up as separate presentations.
+ (reify-old-output): Support reifying individual values of a
+ multiple-value result.
+
+ * slime.el (slime-pre-command-hook): Don't call
+ slime-presentation-command-hook.
+ (slime-post-command-hook): Don't call
+ slime-presentation-post-command-hook.
+ (slime-presentation-command-hook): Removed.
+ (slime-presentation-post-command-hook): Removed.
+
+ * slime.el (slime-presentation-whole-p): New.
+ (slime-same-presentation-p): New.
+ (slime-presentation-start, slime-presentation-end): New.
+ (slime-presentation-around-point): New.
+ (slime-after-change-function): New.
+ (slime-setup-command-hooks): Install slime-after-change-function
+ as an after-change-function.
+
+ * slime.el (slime-repl-enable-presentations): Make
+ slime-repl-presentation nonsticky.
+ (slime-mark-presentation-start, slime-mark-presentation-end): New
+ functions.
+ (slime-mark-presentation-start-handler): Renamed from
+ slime-mark-presentation-start.
+ (slime-mark-presentation-end-handler): Renamed from
+ slime-mark-presentation-end.
+ (slime-presentation): New structure.
+ (slime-add-presentation-properties): New function.
+ (slime-insert-presentation): New function.
+
+2005-08-03 Zach Beane <xach(a)gwi.net>
+
+ * swank-sbcl.lisp (swank-compile-string): Restore honoring of
+ *trap-load-time-warnings*.
+
+2005-08-03 Juho Snellman <jsnell(a)iki.fi>
+
+ * swank-sbcl.lisp: Remove SBCL 0.9.1 support.
+ (swank-compile-string): Funcall the compiled function outside
+ with-compilation-hooks to prevent runtime warnings from
+ popping up a *compiler-notes* buffer.
+
+2005-07-29 Marco Baringer <mb(a)bese.it>
+
+ * doc/slime.texi (Other configurables): Document
+ *dedicated-output-stream-port*.
+
+ * swank.lisp (*dedicated-output-stream-port*): New variable.
+ (open-dedicated-output-stream): Open the stream on the port
+ *dedicated-output-stream-port*.
+
+ * slime.el (slime-set-default-directory): Fix typo in doc string.
+
+2005-07-26 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank.lisp (inspect-for-emacs): Don't make whitespace
+ surrounding :action buttons part of the highlighted region.
+
+ * slime.el (slime-goto-location-buffer): Put "SLIME Source Form"
+ buffer into Lisp mode.
+
+2005-07-26 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (compile-file-for-emacs): Accept optional
+ external-format arg. I frogot to commit this file on 2005-07-05.
+
+ * slime.el (slime-input-complete-p): Skip over strings too.
+
+2005-07-26 Zach Beane <xach(a)xach.com>
+
+ * swank-sbcl.lisp (swank-compile-string): Revert to old string
+ compilation behavior to fix compiler note annotations. Code from
+ Juho Snellman.
+
+2005-07-24 Tom Pierce <tlpierce(a)gmail.com>
+
+ * swank.lisp (format-iso8601-time): New functions. Properly
+ formats a universal-time as an iso8601 string.
+ (inspect-for-emacs integer): Use the new
+ format-iso8601 function when printing an integer as a date.
+
+2005-07-22 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (frame-catch-tags): Remove some debugging
+ forms which were "polluting" the repl buffer when viewing an sldb
+ buffer.
+ (function-source-location): Make :error messages have the proper
+ form (exactly one string argument). This fix also removes the
+ issues with sending unreadble lists (containing #<...> to emacs).
+
+2005-07-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp (find-external-format): Fix typo.
+
+2005-07-06 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-send-sigint): Use the symbol SIGINT stead of the
+ signal number. Suggested by Joerg Hoehle.
+ (slime-compile-file): XEmacs needs the buffer as argument to
+ local-variable-p. Reported by Andy Sloane.
+
+2005-07-05 Helmut Eller <heller(a)common-lisp.net>
+
+ The file variable slime-coding can now be used to specify the
+ coding system to use for C-c C-k. E.g., if the file contains
+ -*- slime-coding: utf-8-unix -*- Emacs will tell the Lisp side
+ to call COMPILE-FILE with an external-format argument.
+
+ * slime.el (slime-compile-file): Send the coding system if
+ the buffer local variable `slime-coding' is bound.
+
+ * swank-backend.lisp, swank-sbcl.lisp, swank-clisp.lisp,
+ swank-lispworks.lisp, swank-cmucl, swank-allegro.lisp,
+ swank-abcl.lisp, swank-corman.lisp
+ (swank-compile-file): New optional argument `external-format'.
+
+ * swank-clisp.lisp (getpid): Undo the last change.
+
+ * swank-corman.lisp (spawn, thread-alive-p): More thread tweaking.
+
+2005-07-03 Joerg Hoehle <hoehle(a)users.sourceforge.net>
+
+ * swank-clisp (describe-symbol-for-emacs): Report :setf and :type
+ where appropriate.
+
+2005-07-03 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (next-single-char-property-change)
+ (previous-single-char-property-change) [xemacs]: Only define them
+ if not present.
+ (next-char-property-change, previous-char-property-change): Define
+ if needed.
+
+ * README: Show examples for the filenames instead of the general
+ "/the/path/to/this/directory". Suggested by Brandon J. Van Every.
+
+ * swank-corman.lisp (default-directory): Return a namestring
+ instead of the pathname.
+ (inspect-for-emacs, inspect-structure): Teach the inspector how to
+ deal with structures.
+ (spawn, send, receive): Implement rudimentary threading support.
+ It's now possible to connect with the :spawn communication style
+ and to bring up a listener. Unfortunately, debugging the
+ non-primary threads doesn't work at all. Still no support for
+ interrupt-thread.
+
+ * slime.el (slime-start-swank-server): Send an extra newline
+ before the "(swank:start-server ...". I don't know why, but this
+ seems to fix the problem when starting CLISP/Win32. Interrupting
+ CLISP/W32 is still horribly broken.
+
+ * swank-loader.lisp (compile-files-if-needed-serially) [corman]:
+ force-output after each file.
+
+2005-07-02 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (save-some-lisp-buffers): New Function.
+ (slime-repl-only-save-lisp-buffers): New customizable variable.
+ (slime-repl-compile-and-load): Use save-some-lisp-buffers.
+ (slime-oos): Use save-some-lisp-buffers.
+
+2005-07-01 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-sbcl.lisp (threaded stuff): make SBCL 0.9.2.9+ work while
+ retaining support for 0.9.2
+
+2005-06-28 G�bor Melis <mega(a)hotpop.com>
+
+ * swank-sbcl.lisp (threaded stuff): horrible hack to make threaded
+ SBCL 0.9.2 work. (also, Happy Birthday Christophe!)
+
+2005-06-21 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (find-matching-packages): Also use nicknames.
+
+2005-06-13 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (list-all-systems-in-central-registry): Delete
+ duplicates.
+
+ * swank-lispworks.lisp (unmangle-unfun): If you rename a package
+ you should rename it everywhere...
+
+2005-06-12 Alexey Dejneka <adejneka(a)comail.ru>
+
+ * slime.el (slime-with-xref-buffer): fix "pgk" typo.
+
+2005-06-12 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank.lisp (ed-in-emacs): allow strings as well as pathnames;
+ don't call emacs for things that the emacs editor doesn't know how
+ to deal with. Return T if we called emacs and NIL if not.
+
+ * slime.el (slime-ed): Change a listp to consp, so that NIL
+ arguments are correctly handled.
+
+2005-06-11 Nikodemus Siivola <nikodemus(a)random-state.net>
+
+ * swank-sbcl.lisp: Patched for SBCL HEAD: utilize the new
+ :source-plist functionality; maintain compatibility with 0.9.1
+ till 0.9.2 is out. Removed cruft left over from previous
+ excercises in supporting both HEAD and latest release.
+
+ * doc/slime.texi: Document Slime as supporting the latest official
+ release of SBCL, as opposed to a specific version number which
+ would need to be updated monthly.
+
+2005-06-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * nregex.lisp (slime-nregex): Rename package to avoid name clashes
+ with other version of this file.
+
+ * swank.lisp (compiled-regex): Use the new package name.
+
+ * slime.el (slime-with-xref-buffer): Gensym package too, to avoid
+ problems when switching to buffers with -*- package: ... -*- file
+ variables. From Antonio Menezes Leitao.
+ (slime-property-bounds): Use the prop argument instead of the
+ hardcoded 'slime-repl-old-output. From Andras Simon.
+
+2005-06-07 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-corman.lisp: Convert to Unix line-endings.
+ (create-socket): Pass through the port argument unmodified,
+ gettting a random port if 0. Requires supporting change in
+ <ccl>/modules/sockets.lisp.
+ (inspect-for-emacs): defimplementation instead of defmethod.
+
+2005-06-06 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * doc/slime.texi, PROBLEMS: Added notes about CCL.
+
+2005-06-03 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-background-activities-enabled-p): Allow
+ background stuff in repl-mode buffers too.
+
+ * swank-cmucl.lisp (sis/misc): Return t for :interactive-p.
+
+2005-06-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-load-system, slime-oos): Fix bug related to file
+ locking. Don't bind the variable system-name. system-name is a
+ predefined Emacs variable and is used among other things for lock
+ filenames.
+
+2005-06-01 Joerg Hoehle <hoehle(a)users.sourceforge.net>
+
+ * swank-clisp (getpid): Updates for current CLISP versions. Use
+ defimplementation. Define always (slime needs it).
+
+2005-06-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-background-activities-enabled-p): Return nil
+ instead of signalling an error if there is a open but no default
+ connection.
+ (slime-current-connection): New helper function.
+ (slime-connection): Use it.
+ (slime-first-change-hook): Only run when
+ slime-background-activities-enabled-p.
+
+2005-06-01 Joerg Hoehle <hoehle(a)users.sourceforge.net>
+
+ * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp.lisp
+ (describe-symbol-for-emacs): Distinguish macro and special
+ operators from functions.
+
+ * slime.el (slime-print-apropos): Must keep in sync with above,
+ therefore added :macro and :special-operator properties.
+
+ * swank.lisp (present-symbol-before-p): Make it conform to its
+ specification -- sort first by package and then by symbol name.
+
+ * swank-clisp.lisp (describe-symbol-for-emacs): Report :alien-type
+ when the name is known as foreign type.
+
+2005-06-01 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-loader.lisp: Redefine compile-files-if-needed-serially for
+ Corman Lisp to load everything from source.
+
+2005-05-27 Espen Wiborg <espenhw(a)grumblesmurf.org>
+
+ * swank-corman.lisp: New file, swank for Corman Lisp.
+
+ * swank.lisp (simple-announce-function): force-output after
+ announcing.
+ (symbol-external-p): Be extra paranoid about the symbol's package;
+ find-symbol barfs on a nil package in Corman Lisp.
+
+ * swank-loader.lisp: Add Corman Lisp support.
+
+2005-05-24 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el text-property-default-nonsticky not defined in
+ xemacs. oops.
+
+2005-05-24 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el meta-w now removes properties before insertion if you
+ cut just a portion of the presentation. Added xemacs
+ support. Enabled in xemacs.
+
+2005-05-23 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el slime-presentation-menu - use with-current-buffer, so
+ that menus work even if you are not in the buffer with the
+ presentation.
+
+ * present.lisp More menu items for pathnames. Remember last
+ slime-stream-p value. *can-print-presentation* t during
+ swank-compiler and during presentation menu action.
+
+2005-05-22 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * present.lisp. (slime-stream-p) check if a stream is destined for
+ output in a slime listener. (checks *connections* looks into pretty-print
+ streams in openmcl and cmucl)
+ Don't present unless (slime-stream-p stream).
+
+ Variable *enable-presenting-readable-objects* The only readable object
+ which is presented are pathnames (e.g. pathnames printed when loading
+ and *load-verbose* is t). Try the useful menu :)
+ More to come if this doesn't cause problems. (nil this if it does)
+
+ *can-print-presentation* t around compile-string-for-emacs,
+ load-file, interactive-eval.
+
+ In cmucl, use fwrappers to modify behaviour rather than redefinition.
+
+2005-05-22 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * present.lisp. mouse-3 now gives a menu for actions on the
+ presentation. See documentation in file for information about how
+ to define menus. Also, disable presentations in inspector. Initial bits
+ of dealing with the possibility of presenting readable objects.
+
+ * slime.el support menu. Xemacs users beware this uses x-popup-menu,
+ which may be fsf specific.
+
+2005-05-20 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank.lisp make repl output presentation work even if
+ present.lisp not loaded
+
+2005-05-20 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-repl-enable-presentations): Default is enabled
+ in GNU Emacs but disabled in XEmacs. Feature is not portable yet.
+ Brutally 80-column'ified alanr's latest changes :-)
+
+2005-05-20 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * bridge.el new file. from ilisp cvs distribution to collect
+ in-band messages using process filter mechanisms. One edit which
+ calls bridge-insert with process argument as well as output
+
+ * present.lisp new file. Enough code to do the following:
+ (swank::presenting-object object stream (print "This is really
+ object")). This makes the string "This is really object" behave
+ like old repl input for the object. Sample code for openmcl and
+ cmucl that hooks this into the printing of unreadable objects This
+ should be part of swank.lisp (and lisp specific files) but I am
+ too chicken to merge yet. For now you have to load this file
+ manually.
+
+ * slime.el changes to support above:
+ slime-repl-enable-presentations: customize to enable this stuff.
+ Default value t. Set to nil to turn it off.
+ slime-presentation-start-to-point: map object ids to the (point)
+ where they start to print out. slime-mark-presentation-start,
+ slime-mark-presentation-end. handlers for the bridge messages.
+ slime-open-stream-to-lisp: When enabled start the bridge and
+ define the handlers.
+
+2005-05-19 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el slime-presentation-map
+
+2005-05-20 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (clear-repl-results): Fixed unbalanced parens. Thanks
+ Lawrence Mitchell.
+
+2005-05-19 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el (slime-presentation-command-hook) new function for
+ nicer behaviour for presentations.
+ (slime-pre-command-hook) do slime-presentation-command-hook
+ (slime-post-command-hook) put pre-command-hook back if goes away
+ (slime-copy-presentation-at-point) mouse-2 copies previous output to point
+ slime-repl-output-mouseover-face what the old output looks like when the mouse moves over it
+ default: box around it like on lispm
+ (slime-repl-insert-prompt) add mouseover face, mouse action. newline after output not propertized.
+ (slime-property-bounds) adjust for lack of propertized newline
+ to fix: presentation region behaviour should be attach to generic property like
+ (:acts-as-token t ) rather than tying to repl-output property
+
+2005-05-19 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (*record-repl-results*): Variable to enable/disable
+ recording of REPL results. True by default.
+ (*repl-results*): Renamed from ****.
+
+ * slime.el (slime-property-bounds): Factored out this common part
+ of slime-repl-grab-old-{input,output}.
+ (slime-read-object): Avoid inline CL code.
+
+2005-05-18 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt>
+
+ * slime.el (slime-repl-inputed-output-face): new face.
+ (slime-current-output-id): New variable.
+ (slime-dispatch-event): Bind slime-current-output-id when
+ neccessary.
+ (slime-repl-insert-prompt): Add the neccessary text properties to
+ the result.
+ (reify-old-output): New function which makes sure swank sees
+ \(swank::get-**** ...) while the user sees the printed
+ representation of the object.
+ (slime-repl-return): When called on a old output (as per the
+ slime-repl-old-output text property, call
+ slime-repl-grab-old-output.
+ (slime-repl-send-input): Added the slime-repl-old-input text
+ property.
+ (slime-repl-grab-old-input): Keep the old input's text
+ properties (unwanted text properties are removed later).
+ (slime-repl-grab-old-output): New function.
+ (slime-repl-clear-buffer): Added call to swank::clear-****
+ (slime-repl-clear-output): Added call to swank::clear-**** and
+ bind inhibit-read-only to nil.
+ (slime-inspect): Call slime-read-object to get the value to
+ inspect.
+ (slime-read-object): New function which either reads an object
+ from the minibuffer or returns the object at point if it has the
+ slime-repl-old-output text property.
+
+ * swank.lisp (*current-id*, ****): New variables.
+ (add-****, get-****, clear-last-****, clear-****): New functions
+ for manipulating the repl history.
+ (listener-eval): Add * to ****.
+
+2005-05-12 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank.lisp Add ability to customize behavior of the repl. To do
+ so, add a function to the list swank::*slime-repl-eval-hooks*.
+ This function is passed the form typed into the repl. The function
+ should decide whether it wants to handle evaluation of the
+ form. If not, call (repl-eval-hook-pass) and the next hook is
+ tried. Otherwise the values the function returns are used instead
+ of calling eval. Inside the body of the function you can also
+ suppress having the repl print the result by calling
+ (repl-suppress-output) and/or suppress the advancement of the
+ history variables (*** ** * /// // /) by calling
+ (repl-suppress-advance-history).
+
+
+2005-05-11 Tim Daly Jr. <tim(a)tenkan.org>
+
+ * swank-source-path-parser.lisp (read-and-record-source-map):
+ Ensure that at least the toplevel form is in the source-map.
+
+2005-05-11 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-remove-old-overlays): Remove overlays in all
+ slime buffers not only in the current buffer.
+ (slime-filter-buffers): New helper.
+ (slime-display-completion-list): Take the completed prefix as
+ additional argument to initialize completion-base-size. This is
+ apparently needed to make mouse-selection working.
+ (slime-maybe-complete-as-filename): Factor for common code in
+ slime-complete-symbol* and slime-simple-complete-symbol.
+
+2005-05-06 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-openmcl.lisp specializer-name didn't handle
+ structure-class which caused meta-. of methods specialized on
+ defstruct arguments to fail.
+
+2005-05-06 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp (post-gc-hook): Include the elapsed time and
+ the size distribution.
+
+2005-05-05 Edi Weitz <edi(a)agharta.de>
+
+ * swank-lispworks.lisp (unmangle-unfun): New function to convert
+ strange symbols in SETF package to SETF function names.
+ (signal-undefined-functions): Use it.
+
+2005-05-04 Edi Weitz <edi(a)agharta.de>
+
+ * swank-lispworks.lisp (call-with-compilation-hooks): Provide
+ better implementation.
+ (compile-file-and-collect-notes): Advice for COMPILE-FILE so
+ pathname information for undefined functions can be recorded.
+ (*within-call-with-compilation-hooks*): New special variable used
+ by CALL-WITH-COMPILATION-HOOKS.
+ (*undefined-functions-hash*): New special variable to record
+ pathname information for undefined functions.
+ (signal-error-database): Make LOCATION parameter optional, use
+ FILENAME info from error database if not provided.
+ (signal-undefined-functions): Make LOCATION parameter optional,
+ use info from *UNDEFINED-FUNCTIONS-HASH* if not provided.
+
+2005-05-03 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (slime-secret): Removed #+unix conditional, suggested
+ by Edi Weitz.
+
+2005-05-02 Mark Wooding <mdw(a)nsict.org>
+
+ * swank.lisp: If ~/.slime-secret exists then insist that Emacs
+ sends the contents (as a password) during initial handshaking.
+ (announce-server-port): Use :IF-EXISTS :ERROR to prevent bad guys
+ from slipping a symlink into /tmp and reading what port Lisp is
+ listening on.
+
+ * slime.el: If ~/.slime-secret exists then send it, as per above.
+
+2005-05-01 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-inspector-reinspect): New function which
+ reinspects the current object.
+ (slime-inspector-mode-map): Bind slime-inspector-reinspect to g.
+
+2005-04-29 Dan Pierson <dlp(a)itasoftware.com>
+
+ * slime.el (slime-parse-context): Fix method parsing so that
+ pressing, say, C-c C-t when point is on a '-' in a symbol name
+ won't break.
+ (slime-browser-map): New variable. Add support for the common 'q'
+ keystroke to quit out of the xref.
+ (slime-fetch-browsable-xrefs): New function. Remove the (FLET ...)
+ entries which appear on at least CMUCL. I don't believe you can
+ actually expand them on any current implementation and they just
+ mess up the browse tree. Use only the method name when looking
+ up (METHOD ...) entries on CMUCL. This really shouldn't be here,
+ but I can't see how to avoid the error thrown by swank:xref.
+ (slime-expand-xrefs): Use it.
+ (slime-call-with-browser-setup): Initialize slime-buffer-package
+ properly. Previously, lisp-mode was called after setting it, but
+ lisp-mode clears all local variables, use lisp-mode-variables
+ instead.
+
+ * swank-cmucl.lisp (toggle-trace): Be more carefully when tracing
+ methods: try both (METHOD ...) and (PCL:FAST-METHOD ...).
+
+2005-04-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp (+header-type-symbols+): Drop the third arg to
+ apropos-list; it's no longer supported in recent CMUCLs.
+
+2005-04-21 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (arglist-to-string): Rolled back the previous change
+ because it interferred with values appearing in parameter lists.
+
+2005-04-20 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (arglist-to-string): Bind *PRINT-ESCAPE* to NIL. This
+ way symbols in arglists are printed as with PRINC, i.e. without
+ package qualifier.
+
+ * swank-sbcl.lisp (preferred-communication-style): Use
+ `linux_no_threads_p' alien variable to decide whether to use
+ :SPAWN. From dan_b for compatibility with new SBCLs.
+
+2005-04-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * PROBLEMS: Warn about old kernels.
+
+ * swank-backend.lisp: Fix some typos.
+
+ * swank-sbcl.lisp (preferred-communication-style): Don't test for
+ sb-futex, it has lost its meaning in 0.8.21.
+
+2005-04-18 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (inferior-lisp-program): Defvar it here, in case it is
+ not defined in loaddefs and inf-lisp is not loaded. (That's the
+ case in XEmacs.)
+
+ * mkdist.sh: update version number.
+
+ * doc/slime.texi: Update version numbers for SBCL and ACL.
+
+2005-04-17 Peter Seibel <peter(a)gigamonkeys.com>
+
+ * swank-loader.lisp (*implementation-features*): Added features
+ for GCL and ECL ...
+ (lisp-version-string): ... and code to compute version
+ string. (Supplied by someone who's email I've misplaced.)
+
+2005-04-14 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-selector): Discard input after sleeping.
+
+2005-04-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (sldb-get-buffer): Create a fresh buffer if there's no
+ buffer for the connection (and don't reuse an existing buffer even
+ if it has a matching name).
+ (slime-buffer-visible-p, slime-ir1-expand): Delete unused
+ functions. Mark some others as unused, but leave them there
+ because they are potentially useful.
+
+ * swank.lisp (with-io-redirection, with-connection)
+ (with-buffer-syntax): Implement macros with `call-with' functions
+ to avoid some code bloat.
+ (call-with-connection, maybe-call-with-io-redirection)
+ (call-with-buffer-syntax): New functions.
+ (interactive-eval): Use from-string instead of read-from-string to
+ avoid problems whit *read-suppress*.
+
+ * swank-sbcl.lisp: Add a few comments.
+
+ * swank-abcl.lisp (print-frame): Trim whitespace to make the
+ backtrace look a bit terser.
+
+2005-04-07 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-net-coding-system): More fixes for
+ non-mule-XEmacsen.
+ (slime-net-coding-system): Even more fixes to make it for
+ mule-XEmacs.
+
+2005-04-05 Juergen Gmeiner <gj(a)gjdv.at>
+
+ * swank-lisworks.lisp (find-top-frame): If we can't find an
+ invoke-debugger frame we take any old frame at the top.
+
+2005-04-04 James McIlree <ovrskeek(a)mac.com>
+
+ * slime.el (find-coding-system, check-coding-system)
+ (process-coding-system, set-process-coding-system): Dummy
+ functions for no-mule-XEmacsen.
+
+2005-04-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-show-maximum-output): New
+ function. Immitate the scrolling behavior of a terminal.
+ (slime-with-output-end-mark, slime-repl-return)
+ (slime-repl-send-input, slime-display-output-buffer): Use it
+ (slime-lisp-implementation-version, slime-machine-instance): New
+ connection variables. Suggested by Eduardo Mu�oz.
+ (slime-set-connection-info): Initialize them.
+
+ * swank.lisp (connection-info): Include version and hostname in
+ the result.
+
+ * swank-cmucl.lisp (breakpoint-values): Fixes for CMUCL-2005-03
+ snapshot.
+
+ * doc/slime.texi: Fix spelling errors.
+
+ * cl-indent.el: Remove the file. Let the Emacs developers
+ maintain it.
+
+2005-04-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (sldb-get-buffer): Initialize the buffer local
+ variables slime-buffer-connection and slime-current-thread when
+ creating a fresh buffer.
+
+ * swank.lisp (spawn-repl-thread): Use
+ *default-worker-thread-bindings* just like spawn-worker-thread.
+ (wrap-sldb-vars): New function. Rebind *sldb-level* to avoid
+ confusion with recursive errors during eval-in-frame.
+ (eval-string-in-frame, pprint-eval-string-in-frame): Use it.
+
+ * swank-allegro.lisp (eval-in-frame): Allegro's
+ eval-form-in-context does nothing special with lexical variables
+ in the frame. Wrap an explicit LET around the form to get similar
+ behavior as in the other Lisps.
+ (inspect-for-emacs (structure-object)): Remove structure related
+ methods. It's already covered by the general case with
+ allegro-inspect.
+ (common-seperated-spec): Deleted
+
+2005-04-01 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-xref-mode): Summarise the most important
+ bindings in the mode description.
+
+ * metering.lisp: Now supports only CLISP and OpenMCL.
+ Removed a lot of really ugly reader-conditionalized code, much of
+ it for archaic lisps (#+cltl2, #+lcl3.0, #+mcl1.3.2, etc).
+
+ * swank-source-path-parser.lisp (check-source-path): Signal an
+ error if a source path is malformed. SBCL sometimes gives (NIL).
+ (source-path-stream-position): Use it.
+
+ * slime.el (slime-goto-definition): Handle :error locations here
+ before any window/buffer changes are made.
+
+2005-04-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-keys): Bind slime-edit-definition-other-window
+ to `C-x 4 .' and slime-edit-definition-other-frame to `C-x 5 .',
+ shadowing the equivalent find-tag... bindings.
+ (slime-goto-definition): In the other-window and other-frame cases,
+ make sure point does not move in the originating window, even when
+ the definition is found in the same buffer.
+
+2005-03-31 Luke Gorrie <luke(a)synap.se>
+
+ * doc/slime.texi (slime-selector): New section.
+ (Inspector): Updated for the post-1.0 inspector.
+
+ * slime.el (slime-selector): Removed unneeded "the" prefixes in
+ descriptions of what the selector methods do.
+
+2005-03-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * PROBLEMS, NEWS, doc/slime.texi: Some updates for the upcoming
+ release.
+
+2005-03-27 Russell McManus <russell_mcmanus(a)yahoo.com>
+
+ * swank-clisp.lisp (getpid): Try sys::process-id if
+ sys::program-id doesn't exist.
+
+2005-03-23 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (commit-edited-value): Read a backquated string,
+ instead of quating the result of read. This allows one to put
+ ,(form) into edit-value buffers.
+
+2005-03-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-lispworks.lisp (swank-compile-string): Bind *print-radix*
+ to t, to avoid problems if somebody uses different values for
+ *print-base* and *read-base*. Reported by Alain Picard.
+ (emacs-connected): Add default methods for
+ environment-display-notifier and environment-display-debugger.
+
+2005-03-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (locate-compiler-note): Handle errors in macros
+ better.
+ (source-file-source-location): Read the snippet at the right
+ position.
+
+ * swank-source-file-cache.lisp (read-snippet): Take the start
+ position as optional argument.
+
+2005-03-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (quit-lisp): If we are running multithreaded,
+ terminate all other threads too. (still broken in 0.8.20.27; used
+ to work in ~0.8.20.2.)
+ (with-debootstrapping, call-with-debootstrapping): Remove ugly
+ backward compatibility code.
+ (sbcl-source-file-p, guess-readtable-for-filename): New utilities.
+ (function-source-location): Handle work off to helper functions.
+ (find-function-source-location): New function. Use the
+ shebang-readtable for SBCL source files.
+ (function-source-position, function-source-filename)
+ (function-source-write-date, function-toplevel-form-number)
+ (function-hint-snippet, function-has-start-location-p)
+ (function-start-location): New helpers.
+ (safe-source-location-for-emacs): Don't catch errors if
+ *debug-definition-finding* is true.
+ (inspect-for-emacs): Minor beautifications.
+
+ * swank.lisp (commit-edited-value): Use buffer syntax.
+ (compile-file-for-emacs, compile-string-for-emacs): Bind
+ *compile-print* to nil.
+
+ * swank-cmucl.lisp (call-with-debugging-environment): Rebind
+ kernel:*current-level* 0. Useful for debugging pretty printer
+ code.
+ (inspect-for-emacs): Show details of interpreted functions.
+
+2005-03-21 Luke Gorrie <luke(a)synap.se>
+
+ * swank-sbcl.lisp (function-source-location): For definitions
+ compiled in Emacs buffers, include the :emacs-string as a :snippet
+ hint for search-based M-. lookup.
+
+2005-03-21 Edi Weitz <edi(a)agharta.de>
+
+ * swank-loader-lisp (*implementation-features*, *os-features*,
+ *architecture-features*): LispWorks was completely missing.
+
+2005-03-18 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-complete-symbol*-fancy): Now nil by default.
+
+2005-03-18 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-source-path-parser.lisp (make-source-recording-readtable):
+ Ignore non-ascii chars.
+
+ * swank-sbcl.lisp (swank-compile-string): Re-implemented. This
+ time with temp-files and proper source-location tracking.
+ (install-debug-source-patch, debug-source-for-info-advice): Patch
+ SBCL's debug-source-for-info so that we can dump our own bits of
+ debug info.
+ (function-source-location, code-location-source-path): Rewritten
+ to handle C-c C-c functions. Also use the source-path to locate
+ the position.
+ (locate-compiler-note): Renamed from resolve-note-location.
+ (temp-file-name, call/temp-file): New utilities.
+ (file-source-location, lisp-source-location)
+ (temp-file-source-location, source-file-source-location)
+ (string-source-position, code-location-debug-source-info)
+ (code-location-debug-source-name, code-location-debug-source-created,)
+ (code-location-debug-fun-fun, code-location-from-emacs-buffer-p)
+ (function-from-emacs-buffer-p, function-debug-source-info)
+ (info-from-emacs-buffer-p, code-location-has-debug-block-info-p)
+ (stream-source-position): Lots of new helper functions.
+ (with-debootstrapping): Moved upwards so that it can be used for
+ source location searching.
+ (source-location-for-emacs): Deleted
+
+2005-03-16 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime/swank.lisp (*macroexpand-printer-bindings*): New user
+ variable.
+ (apply-macro-expander): Use it.
+ (call-with-bindings): Bind variables in reverse order. Thit makes
+ it easer to cons or push a new binding at the front the list.
+ (with-bindings): New macro.
+
+ * slime.el (slime-run-when-idle): New function to hide
+ Emacs/XEmacs differences.
+ (slime-process-available-input): Use it.
+
+ * swank-loader.lisp (unique-directory-name): Rewritten to avoid
+ the rather irritating warning that (warn "Don't know ...") is
+ unreachable.
+
+2005-03-13 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-dispatch-event): Use `slime-busy-p' to control
+ the "; pipelined request" message. This way it takes requests
+ blocked in the debugger into account and avoids spurious messages.
+
+ * swank.lisp (inspect-for-emacs symbol): Add an "unintern it"
+ action for symbols.
+
+ * swank-source-file-cache.lisp (read-snippet): Skip comments and
+ whitespace in SBCL. The source-positions reported by SBCL are not
+ adjusted to skip over whitespace before the definition.
+
+ * swank-sbcl.lisp (function-source-location): Updated for revised
+ sb-introspect patch:
+ s/DEFINITION-SOURCE-CREATED/DEFINITION-SOURCE-WRITE-DATE/
+
+ * swank-loader.lisp (*os-features*): Added :mswindows. Thanks Will
+ Glozer.
+
+2005-03-12 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-edit-value): New function on `C-c E'. Prompts
+ for a Lisp expression, evaluates and displays the result in a new
+ buffer for editing, and then setf's the edited value in Lisp after
+ you press C-c C-c. Usage example: `C-c E asdf:*central-registry*'
+ Minor docstring and pull-down-menu changes.
+
+ * swank.lisp (value-for-editing, commit-edited-value): New
+ functions for slime-edit-value.
+
+ * swank-allegro.lisp (toggle-trace): Fix from Antonio Menezes
+ Leitao.
+
+ * swank-sbcl.lisp: Use swank-source-file-cache to find snippets of
+ definitions. M-. is now much more robust to modifications in the
+ source file.
+ NOTE: To be effective requires a patch to sb-introspect that I
+ have posted to sbcl-devel.
+
+ * swank-source-file-cache.lisp: Factored this into its own file,
+ from swank-cmucl.lisp.
+
+ * swank-loader.lisp, swank-cmucl.lisp: Updated for the above.
+
+2005-03-10 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt>
+
+ * slime.el (slime-toggle-trace-fdefinition): If there is no symbol
+ at point then prompt for one.
+
+2005-03-09 Peter Seibel <peter(a)gigamonkeys.com>
+
+ * swank-loader.lisp (*architecture-features*): Added :pc386 for CLISP.
+ (unique-directory-name): Change ERROR to WARN.
+
+ * slime.el (slime-register-lisp-implementation): Add facility for
+ registering lisp implementations with symbolic names that can be
+ passed to C-u M-x slime.
+
+2005-03-08 Peter Seibel <peter(a)gigamonkeys.com>
+
+ * doc/Makefile (clean): added clean and really_clean targets.
+ (all): and added slime.pdf to all prerequisites.
+
+ * swank-loader.lisp (*implementation-features*): Whoops. Forgot
+ CLISP.
+ (*architecture-features*): Added :x86-64 for SBCL on AMD64 (thanks
+ Vincent Arkesteijn)
+
+2005-03-07 Peter Seibel <peter(a)gigamonkeys.com>
+
+ * swank-loader.lisp (unique-directory-name): Replaced *lisp-name*
+ variable with more sophisticated version that accounts for impl,
+ impl version, os, and hardware architecture.
+
+2005-03-07 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp: Fixed parenthesis-balancing problem.
+
+2005-03-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-easy-menu): Add menu item for
+ slime-complete-form.
+
+ * swank.lisp (format-arglist-for-echo-area): Use extra-keywords to
+ enrich the list of keywords.
+ (arglist-to-string): Remove extraneous whitespace.
+ (keyword-arg, optional-arg): New structures.
+ (decode-keyword-arg, decode-optional-arg): Return structure
+ objects rather than multiple values.
+ (encode-keyword-arg, encode-optional-arg, encode-arglist): New
+ functions.
+ (arglist): New slot key-p.
+ (decode-arglist): Handle &whole, &environment. Store more
+ information on optional and keyword args, set arglist.key-p.
+ (values-equal?): Removed.
+ (print-decoded-arglist-as-template): If keyword is
+ not a keyword symbol, quote it in the template.
+ (extra-keywords): Return a secondary value (allow-other-keys).
+ For make-instance, try to finalize the class if it is not
+ finalized yet (fix for Allegro CL 6.2). If class is not
+ finalizable, use direct slots instead of slots and indicate that
+ the keywords are not complete.
+ (enrich-decoded-arglist-with-extra-keywords): New function, use
+ the secondary value of extra-keywords.
+ (arglist-for-insertion, complete-form): Use it here.
+ (remove-keywords-alist): New variable.
+ (remove-actual-args): When the keyword :test is provided, don't
+ suggest :test-not and vice versa.
+
+ * swank-backend.lisp (:swank-mop package): Export
+ finalize-inheritance.
+
+2005-03-06 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp: Export *LOG-OUTPUT*.
+
+2005-03-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-net-sentinel): Always print a message when the
+ lisp disconnects.
+ (slime-inferior-lisp): Don't display the buffer. Let callers do
+ that.
+ (slime): Display the inferior buffer here.
+ (slime-quit-lisp, slime-quit-sentinel): Use set a special sentinel
+ and do most of the cleanups there.
+ (slime-repl-sayoonara): Use slime-quit-lisp.
+ (slime-restart-inferior-lisp, slime-restart-inferior-lisp-aux)
+ (slime-restart-sentinel): Use a special sentinel to restart
+ processes.
+ (slime-hide-inferior-lisp-buffer): Do the windows arrangement a
+ bit differently. Related to restart-lisp.
+ (slime-repl-buffer): Take the connection as second optional
+ argument. Useful for rearranging windows for dead processes.
+
+ * swank-allegro.lisp (call-with-debugging-environment)
+ (find-topframe): Hide the first 2 frames. Those are created
+ by swank-internal functions.
+
+2005-03-04 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt>
+
+ * swank-allegro.lisp (process-fspec-for-allegro, toggle-trace):
+ Handle setf functions.
+ (tracedp): Fix free variable.
+
+ * slime.el (slime-trace-query): The :defgeneric query was bogus.
+ (slime-extract-context): Don't skip over the method name if we are
+ already at the end of the name.
+
+2005-03-03 Nikodemus Siivola <tsiivola(a)cc.hut.fi>
+
+ * swank-sbcl.lisp: Fixed for latest SBCL HEAD revision and
+ temporarily backwards-compatible with the current release.
+
+2005-03-02 Marco Baringer <mb(a)bese.it>
+
+ * swank-loader.lisp Look for a file in the same directory as
+ swank-loader.lisp called site-init.lisp. If it exists we load that
+ instead of attempting to load ~/.swank.lisp.
+ (user-init-file): Superseded by load-user-init-file.
+ (load-user-init-file): New function.
+ (load-site-init-file): New function.
+
+2005-03-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-who-bindings): Bind who-specializes to C-c W a.
+ (slime-extract-context): Renamed from name-context-at-point.
+ (slime-beginning-of-list): Renamed from out-first.
+ (slime-slime-parse-toplevel-form): Renamed from definition-name.
+ (slime-arglist-specializers): Renamed from parameter-specializers.
+ (slime-toggle-trace-function, slime-toggle-trace-defgeneric)
+ (slime-toggle-trace-defmethod, slime-toggle-trace-maybe-wherein)
+ (slime-toggle-trace-within): Deleted. Everything is now handled
+ by slime-trace-query.
+ (slime-calls-who): For symmetry with silme-who-calls.
+ (slime-edit-definition-with-etags): Better intergration with TAGS.
+ (slime-edit-definition-fallback-function): Mention it in the
+ docstring.
+
+ * swank-backend (calls-who, toggle-trace): New functions.
+ (toggle-trace-function, toggle-trace-generic-function-methods,
+ (toggle-trace-method, toggle-trace-fdefinition-wherein): Replaced
+ by toggle-trace.
+
+ * swank.lisp (*sldb-printer-bindings*, *swank-pprint-bindings*):
+ New variables. The alists replace the variables which where
+ previously hidden with the define-printer-variables macro.
+ (define-printer-variables, with-printer-settings): Deleted,
+ because the variable names where not visible in the source code.
+ (swank-toggle-trace): Renamed from toggle-trace-fdefinition.
+
+ * swank-cmucl.lisp, swank-lispworks, swank-sbcl.lisp,
+ swank-allegro.lisp (toggle-trace): Update tracing code for new
+ interface.
+
+2005-02-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-dispatch-event): Add :eval-no-wait and :eval
+ events.
+ (slime-eval-for-lisp): New function.
+ (sldb-buffers): Delete the variable. Use buffer-list instead.
+
+ * swank.lisp: (eval-for-emacs): Use the new backend function
+ call-with-debugger-hook.
+ (eval-in-emacs): Cleaned up. Add support for synchronous RPCs.
+ (receive-eval-result): New function.
+ (dispatch-event, read-from-socket-io, send-to-socket-io): New
+ :eval event. Rename :%apply to :eval-no-wait.
+ (read-user-input-from-emacs, evaluate-in-emacs): Increment
+ *read-input-catch-tag* instead of re-binding it. Reduces the
+ danger of throwing to the wrong tag a bit.
+
+ * swank-backend.lisp (call-with-debugger-hook): New function.
+ Useful if the backend needs special incantations for BREAK.
+ (toggle-trace-function): Add a default implementation for simple
+ symbols.
+
+ * swank-lispworks.lisp (slime-env): New class.
+ (call-with-debugger-hook): Use env:with-environment to pop up our
+ debugger on a BREAK.
+ (toggle-trace-method, parse-fspec, tracedp, toggle-trace):
+ Implement method tracing.
+
+ * swank-sbcl.lisp (call-with-debugger-hook): Bind
+ sb-ext:*invoke-debugger-hook* instead of setting it in
+ emacs-connected.
+ (emacs-connected): Deleted.
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Reduce
+ verbosity by setting the :print argument for compile-file to nil.
+
+2005-02-23 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-startup-animation, slime-repl-update-banner):
+ Put the animation back in to keep the kids quiet.
+ (slime-kill-without-query-p): Change default to nil.
+ (slime-eval-describe, slime-eval-region)
+ (slime-pprint-eval-last-expression): Fix typos in docstrings.
+ (slime-eval/compile-defun-dwim): Deleted. We never had a key
+ binding anyway.
+
+2005-02-22 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-complete-form): Emacs 20 compatibility fix.
+ (slime-repl-update-banner): Remove animation stuff.
+ (slime-startup-animation): Deleted.
+
+ * swank-lispworks.lisp (compute-applicable-methods-using-classes):
+ Implement it.
+
+2005-02-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Supersede the command slime-insert-arglist with the new command
+ slime-complete-form and bind it to C-c C-s. The command completes
+ an incomplete form with a template for the missing arguments.
+ There is special code for discovering extra keywords of generic
+ functions and for handling make-instance. Examples:
+
+ (subseq "abc" <C-c C-s>
+ --inserts--> start [end])
+ (find 17 <C-c C-s>
+ --inserts--> sequence :from-end from-end :test test
+ :test-not test-not :start start :end end :key key)
+ (find 17 '(17 18 19) :test #'= <C-c C-s>
+ --inserts--> :from-end from-end
+ :test-not test-not :start start :end end :key key)
+ (defclass foo () ((bar :initarg :bar)))
+ (defmethod initialize-instance :after ((object foo) &key blub))
+ (make-instance 'foo <C-c C-s>
+ --inserts--> :bar bar :blub blub initargs...)
+
+ * swank.lisp (arglist): New struct for storing decoded arglists.
+ (decode-arglist): New function.
+ (arglist-keywords, methods-keywords, generic-function-keywords,
+ applicable-methods-keywords): New functions.
+ (decoded-arglist-to-template-string,
+ print-decoded-arglist-as-template): New functions.
+ (arglist-to-template-string): Rewrite using above functions.
+ (remove-actual-args): New function.
+ (complete-form): New slimefun.
+
+ * swank.lisp (extra-keywords): New generic function.
+
+ * swank-backend.lisp (:swank-mop package):
+ Export compute-applicable-methods-using-classes.
+
+ * swank.lisp (arglist-for-insertion): Use extra-keywords to
+ enrich the list of keywords.
+
+ * swank.lisp (valid-operator-symbol-p): New function.
+ (valid-operator-name-p): Use valid-operator-symbol-p.
+
+ * slime.el (slime-complete-form): New command.
+ (slime-keys): Bind C-c C-s to slime-complete-form rather than
+ slime-insert-arglist.
+
+2005-02-18 Antonio Menezes Leitao <aml(a)gia.ist.utl.pt>
+
+ Improve the trace mechanism (on lisps that support it). SLIME is
+ now able to trace/untrace flet/labels functions, methods and, of
+ course, regular and generic functions.
+
+ In the process support for sending code to emacs form the lisp was
+ added. The code, elisp forms, is sent over the wire like normal
+ lisp code, evaluated in emacs and the return value is returned
+ back to the lisp.
+
+ * slime.el (slime-dispatch-event): Added the :evaluale-in-emacs
+ dispatch state which simply parses the message and class
+ evaluate-in-emacs.
+ (evaluate-in-emacs): New function.
+ (complete-name-context-at-point, name-context-at-point, out-first,
+ definition-name, parameter-specializers,
+ slime-toggle-trace-fdefinition, slime-toggle-trace-function,
+ slime-toggle-trace-defgeneric, slime-toggle-trace-defmethod,
+ slime-toggle-trace-maybe-wherein, slime-toggle-trace-within): New
+ functions implementing the new intelligent slime trace.
+
+ * swank-backend.lisp (toggle-trace-function,
+ toggle-trace-generic-function-methods, toggle-trace-method,
+ toggle-trace-fdefinition-wherein,
+ toggle-trace-fdefinition-within): New backend functions
+ for the new trace facility.
+
+ * swank.lisp (dispatch-event): Handle the :evaluate-in-emacs
+ message type.
+ (evaluate-in-emacs): New function.
+
+ * swank-allegro.lisp (toggle-trace-generic-function-methods,
+ toggle-trace, toggle-trace-function, toggle-trace-method,
+ toggle-trace-fdefinition-wherein,
+ toggle-trace-fdefinition-within): Implement.
+ (process-fspec-for-allegro): New function.
+
+ * swank-cmucl.lisp (toggle-trace-generic-function-methods,
+ toggle-trace-function, toggle-trace-method,
+ toggle-trace-fdefinition-wherein): Implement.
+ (toggle-trace, process-fspec): New functions.
+
+ * swank-sbcl.lisp (toggle-trace-generic-function-methods,
+ toggle-trace-function, toggle-trace-method,
+ toggle-trace-fdefinition-wherein): Implement.
+ (toggle-trace, process-fspec): New functions.
+
+2005-02-02 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: Require the timer package explicitly.
+
+2005-02-02 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-repl-send-input): Move some properties
+ of old REPL input (e.g. read-only) from text properties into an
+ overlay, so that kill/yank will leave them behind. Left
+ `slime-repl-old-input' as a text properties because it's more
+ convenient to lookup that way.
+ (slime-repl-return): Ignore `slime-repl-old-input' property if the
+ point is in front of the current REPL prompt, i.e. if the user has
+ copy&pasted some old REPL input into the current input area.
+
+2005-01-30 Bryan O'Connor <bryan-slime(a)lunch.org>
+
+ * slime.el (slime-goto-location-position): Changed the regexp to
+ require the function-name to be followed by a
+ non-symbol-constituent character \S_. Previously, a function-name
+ of "find" first matched find-if-not if it occured earlier in the
+ file.
+
+2005-01-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-busy-p): Ignore debugged continuations to enable
+ arglist lookup while debugging. Suggested by Lynn Quam.
+ (sldb-continuations): New buffer local variable in sldb buffers to
+ keep track of debugged continuations.
+ (sldb-debugged-continuations): New function.
+ (sldb-buffers): Renamed from sldb-remove-killed-buffers.
+ (slime-eval-print): New function to insert the stream output and
+ the result of an evaluation in the current buffer.
+ (slime-eval-print-last-expression): Use it.
+ (slime-interactive-eval): Use slime-eval-print when a prefix
+ argument was given.
+
+ * swank.lisp (*pending-continuations*, eval-in-emacs)
+ (debugger-info-for-emacs): Keep track of debugged continuation the
+ new variable *pending-continuations* and include the list of
+ active continuations in the debugger info for Emacs.
+ (eval-and-grab-output): New function. Used by slime-eval-print.
+ (*log-output*): Renamed from *log-io*. Use *standard-error* as
+ initial value instead of *terminal-io*. CMUCL opens its own tty
+ and that makes it hard to redirect to output with a shell.
+ *standard-error* writes its output to file descriptor 2.
+ (*canonical-package-nicknames*): Fix typo.
+
+2005-01-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (parse-symbol): Don't break if the package doesn't
+ exist. Reported by Lynn Quam.
+
+2005-01-20 Ian Eslick <eslick(a)csail.mit.edu>
+
+ * swank-allegro.lisp (restart-frame): Handle frames with arguments
+ better.
+
+2005-01-20 Edi Weitz <edi(a)agharta.de>
+
+ * swank-allegro.lisp (handle-undefined-functions-warning): Prevent
+ breakage if the undefined function is called at multiple
+ locations.
+
+2005-01-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-gray.lisp (stream-unread-char): If the char argument
+ doesn't match the contents in the buffer, ignore it and emit a
+ warning instead.
+
+2005-01-19 Utz-Uwe Haus <haus+slime(a)merkur.math.uni-magdeburg.de>
+
+ * swank-cmucl.lisp (breakpoint): Add a slot for return values to
+ make return values inspectable in the debugger.
+ (signal-breakpoint): Initialize the new slot.
+
+2005-01-19 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de>
+
+ * slime.el (slime-insert-arglist): Inserts a template for a
+ function call instead of the plain arglist; this makes a
+ difference for functions with optional and keyword arguments.
+
+ * swank.lisp (arglist-to-template-string): New function.
+ (arglist-for-insertion): Use it
+ (decode-keyword-arg, decode-optional-arg): New functions.
+
+2005-01-19 Lars Magne Ingebrigtsen <larsi(a)gnus.org>
+
+ * slime.el (slime-header-line-p): Customize variable to
+ enable/disable the header-line in the REPL.
+
+2005-01-18 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-complete-symbol*-fancy): New variable to enable
+ extra bells and whistles with slime-complete-symbol*. Currently
+ controls whether to use arglists semantically. Default is t.
+ (slime-complete-symbol*-fancy-bit): Factored out this function.
+ Only do "semantic" completion when the symbol is in
+ function-position, avoid interning argument names in Emacs, and
+ don't display arglists if the minibuffer is active.
+
+2005-01-14 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-repl-send-input): Make old input read-only using
+ an overlay instead of a text property. This way if you copy&paste
+ the input elsewhere it will become editable (overlay is associated
+ with the buffer region and not the text).
+
+2005-01-14 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-complete-symbol*): Maybe insert closing
+ parenthesis or space (depending on arglist) after symbol
+ completion has finished. Optionally also show arglist.
+
+2005-01-13 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp (create-socket): The byte-order of the :host
+ argument for CREATE-INET-LISTENER was changed in the Jan 2005
+ snapshot. Test whether the symbol 'ext:socket-error exists to
+ decide if we are in a older version.
+ (resolve-hostname): Return the address in host byte-order.
+
+2005-01-12 Robert Lehr <bozzio(a)the-lehrs.com>
+
+ * slime.el (slime-changelog-date): Return nil if the ChangLog file
+ doesn't exits.
+ (slime-repl-update-banner): Write "ChangeLog file not found" if
+ the ChangeLog doesn't exist.
+
+2005-01-12 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime.el (slime-inspector-operate-on-click): New command for
+ inspecting the value value at the clicked-at position or invoking
+ an inspector action.
+ (slime-inspector-mode-map): Bind it to mouse-2.
+ (slime-inspector-insert-ispec): Add mouse-face properties for
+ clickable values and action buttons.
+
+2005-01-12 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*default-worker-thread-bindings*): New variable to
+ initialize dynamic variables in worker threads.
+ (spawn-worker-thread, call-with-bindings): New helper functions.
+ (thread-for-evaluation): Use them.
+
+2005-01-10 Utz-Uwe Haus <haus+slime(a)merkur.math.uni-magdeburg.de>
+
+ * swank-sbcl.lisp (profile-package): Add implementation for SBCL.
+
+2005-01-10 Eduardo Mu�oz <emufer(a)terra.es>
+
+ * swank.lisp (inspect-for-emacs-list): LispWorks has a low args
+ limit for apply: use reduce instead of apply.
+
+2005-01-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-conservative-indentation): The default is now
+ nil. Suggested by Travis Cross.
+
+2005-01-10 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de>
+
+ * slime.el (slime-inspector-next-inspectable-object): Accept a
+ prefix argument and make wrapping around more reliable. The code
+ is adapted from `widget-move'.
+ (slime-inspector-previous-inspectable-object): New command.
+ (slime-inspector-mode-map): Bind to S-TAB.
+
+2004-12-16 Martin Simmons <martin(a)xanalys.com>
+
+ * swank-lispworks.lisp (create-socket): Work around bug in
+ comm::create-tcp-socket-for-service on Mac OS LW 4.3.
+
+2004-12-16 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-complete-symbol*): Bind
+ comint-completion-addsuffix so unambiguous or exact completion
+ closes the string automatically.
+
+2004-12-16 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de>
+
+ * slime.el (slime-keys): Bind M-* to
+ slime-pop-find-definition-stack for compatibility with standard
+ Emacs conventions.
+
+2004-12-16 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-source-path-parser.lisp (read-source-form): New function
+ which uses *read-suppress* properly. Common code from
+ source-path-stream-position and form-number-stream-position.
+ (source-path-stream-position): Use it.
+
+ * swank-cmucl.lisp (form-number-stream-position): Use
+ read-source-form.
+
+ * swank.lisp (frame-for-emacs): Print the frame number a little
+ nicer with ~2D.
+
+2004-12-15 Matthias Koeppe <mkoeppe(a)merkur.math.uni-magdeburg.de>
+
+ * slime.el (slime-lisp-modes): New variable to make C-c C-k
+ customizable and usable in scheme-mode.
+ (slime-compile-file): Use it.
+
+2004-12-15 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp, swank-backend.lisp (frame-package): Delete it.
+ Include the package name for local variables because it is utterly
+ confusing if `eval-in-frame' doesn't work due to missing package
+ prefixes.
+
+ * swank-source-path-parser.lisp (source-path-stream-position):
+ Bind *read-suppress* to nil before calling
+ read-and-record-source-map.
+
+ * swank-clisp.lisp (*buffer-name*, *buffer-offset*): Move
+ definitions upward before the first use.
+
+2004-12-15 Bryan O'Connor <bryan-slime(a)lunch.org>
+
+ * slime.el (slime-edit-definition): Switch to the other frame if
+ the `where' is 'frame.
+ (slime-edit-definition-other-frame): New function.
+
+2004-12-15 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-send-input): Make the input read-only to
+ avoid confusion.
+ (slime-make-region-read-only): New function.
+
+2004-12-13 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-mode-map): Bind <home> to slime-repl-bol.
+ Suggested by Chris Capel.
+ (slime-repl-grab-old-input): Remove the 'old-input text-property
+ from the copied text. Reported by Tim Oates.
+ (slime-repl-grab-old-input): Append the old input to the current
+ input by default. If the new `replace' argument is true, replace
+ the current input. Suggested by Antonio Menezes Leitao.
+ (slime-repl-return): Pass the prefix argument to
+ slime-repl-grab-old-input.
+
+2004-12-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (*sldb-print-pretty*, *sldb-print-circle*)
+ (*sldb-print-length*, *sldb-print-level*, *sldb-print-lines*)
+ (*sldb-print-pprint-dispatch*): Export those symbols.
+
+2004-12-05 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-global-variable-name-p): Also return true for
+ names of constants like +foo+. Suggested by Christian Lynbech.
+
+ * swank-allegro.lisp (handle-compiler-warning): Handle
+ undefined-functions warnings by looking the fromat-arguments of
+ the condition.
+ (compiler-undefined-functions-called-warning-p)
+ (location-for-warning, handle-undefined-functions-warning): New
+ functions.
+
+ * swank-cmucl.lisp (*install-gc-hooks*): New user variable.
+ (sending-safe-p): New predicate.
+ (pre-gc-hook, post-gc-hook): Use it.
+
+ * swank.lisp (eval-region): Use a simple loop.
+
+2004-12-02 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp: (inspect-for-emacs (symbol)): Handle non-interned
+ symbols.
+
+ * slime.el (slime-repl-clear-buffer, slime-repl-clear-output): Fix
+ docstrings.
+
+2004-11-29 Lynn Quam <quam(a)ai.sri.com>
+
+ * slime.el (slime-global-variable-name-p): Allow optional
+ "<package-name>:" or "<package-name>::".
+
+2004-11-29 Chris Capel <pdf23ds(a)gmail.com>
+
+ * swank.lisp (macro-indentation): Ignore &whole, &aux, and
+ &environment args.
+
+2004-11-29 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-repl-wrap-history): New user variable.
+ (slime-repl-history-replace): Implement wrap around.
+ (slime-repl-easy-menu): Fix binding for "Next Input". Reported by
+ Surendra Singhi.
+
+ * swank-lispworks.lisp (list-callers-internal): Return the
+ function if dspec:object-dspec returns nil.
+ (xref-results): Previously, functions for which
+ dspec:dspec-definition-locations returned nil were ignored.
+ Include them with a unknown source-location.
+
+ * swank-abcl.lisp, swank-allegro.lisp, swank-clisp.lisp,
+ swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp,
+ swank-lispworks (accept-connection): The :external-format argument
+ defaults now to :iso-latin-1-unix.
+
+2004-11-26 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-cmucl.lisp (read-into-simple-string): Use #-cmu19 instead
+ of #+cmu18e.
+
+2004-11-25 Chris Capel <pdf23ds(a)gmail.com>
+
+ * slime.el (slime-indent-and-complete-symbol): Echo the arglist if
+ there's no symbol before point. Don't complete after parens.
+ (slime-echo-arglist): Factorized from slime-space.
+ (slime-space): Use it.
+ (slime-repl-history-replace): Clear the input at the end of the
+ history.
+
+ * swank.lisp (arglist-to-string): Don't show &whole, &aux and
+ &environment args.
+ (clean-arglist): New function.
+
+2004-11-25 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-net-coding-system): Emacs does funky encoding
+ for `raw-text-unix' use `binary' instead.
+ (slime-safe-encoding-p): New function.
+ (slime-net-send): Use it and don't try to send stuff which can't
+ be decoded by Lisp.
+ (slime-inferior-lisp-program-history): XEmacs compatibility:
+ declare it as a variable.
+ (slime-xref-mode): In Emacs 21, set delayed-mode-hooks to nil
+ because we don't want to run the lisp-mode-hook. Reported by
+ Chris Capel.
+
+ * swank.lisp (dispatch-loop): Catch errors and close the
+ connection. It's almost impossible to run the debugger inside the
+ control-thread, so let it crash instead. A backtrace would be
+ nice, though.
+ (cleanup-connection-threads): Can now be called in the
+ control-thread. Add a check to avoid thread suicide.
+ (start-swank-server-in-thread): Fix the call to start-server.
+
+ * swank-sbcl.lisp (%thread-state-slot, %thread-state): Refactored
+ from thread-status.
+ (thread-status): Use it.
+ (all-threads): Exclude zombies.
+
+2004-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start-and-load): Use vanilla comint instead of
+ inf-lisp. Let's try that for a while.
+ (slime): Ask for the coding system when invoked with C-u C-u.
+ (slime-net-coding-system, slime-net-valid-coding-systems): Add
+ some alternatives for older Emacsen.
+ (slime-find-buffer-package): Skip quotes. Old code looks
+ sometimes like (in-package 'foo).
+ (slime-repl-mode-map): Inhibit C-c C-z. Avoids accidental loading
+ inf-lisp.
+ (slime-net-coding-system): Use find-coding-system in XEmacs.
+ coding-system-p means something different here.
+ (slime-repl-mode-map): XEmacs compatibility: use (kbd "C-<up>")
+ instead of [C-up].
+
+ * swank.lisp (inspect-for-emacs-list): subseq on improper lists
+ breaks in Lispworks. Handle that case better.
+
+ * swank-sbcl.lisp (inspect-for-emacs)[code-component]: Disassemble
+ code-components too.
+
+ * swank-backend.lisp (import-swank-mop-symbols): Better error
+ message for the assertion.
+
+ * swank-cmucl.lisp (debug-var-value): Return #:invalid or
+ #:unknown instead of :<not-available>.
+ (swank-compile-file): Load the fasl file only if load-p is true.
+ (inspect-for-emacs, inspect-alien-record, inspect-alien-pointer):
+ Add inspector support for some alien types.
+
+ * swank-lispworks.lisp (emacs-connected): Set the sigint handler
+ only for single threaded operation. I.e. when
+ *communication-style* is nil.
+
+ * swank-allegro.lisp (set-external-format): New function. Use LF
+ as eol mark.
+ (call-with-compilation-hooks): Trap compiler-notes too.
+
+2004-11-24 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-repl-mode-map): Add C-up and C-down to move
+ through history. Consistent with comint-mode.
+ (slime-repl-mode-map): Add slime-load-file on `C-c C-l' and
+ slime-compile-file on `C-c C-k'. This is mostly to override
+ unwanted inf-lisp bindings in lisp-mode-map.
+ (slime-load-file): Handle (buffer-file-name) being nil.
+
+2004-11-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (make-socket-io-stream): Add some #+sb-unicode.
+
+2004-11-20 Travis Cross <travis(a)crosswirecorp.com>
+
+ * swank-sbcl.lisp (thread-status): Fix unbalanced parenthesis.
+
+2004-11-20 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (make-stream-interactive): Only add ouptut
+ streams (subclasses of ccl:fundamental-output-stream) to
+ ccl::*auto-flush-streams*.
+
+2004-11-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-net-coding-system): New variable. Specifies the
+ coding system to use for network communication. The default is
+ iso-latin-1 and should work for all Lisps. Only a small set of
+ coding systems is currently supported.
+ (slime-net-valid-coding-systems): New variable. A list of coding
+ systems which may be used.
+ (slime-check-coding-system, slime-coding-system-mulibyte-p)
+ (slime-coding-system-cl-name): New utility function for coding
+ systems.
+ (slime-net-connect, slime-make-net-buffer,
+ slime-open-stream-to-lisp): Use it.
+ (slime-net-decode-length, slime-net-encode-length): Renamed from
+ slime-net-read3 and slime-net-enc3. The length is now encoded as
+ a 6 char hex string.
+
+ * swank.lisp (*coding-system*): New variable.
+ (start-server): Accept external-format as argument.
+ (create-server, create-swank-server, setup-server)
+ (serve-connection, open-dedicated-output-stream)
+ (create-connection): Ditto.
+ (defstruct connection): Add external-format slot.
+ (decode-message-length): New function for new length encoding.
+ (decode-message): Use it.
+ (encode-message): Use new encoding.
+
+ * swank-cmucl.lisp (accept-connection): Accept external-format
+ argument.
+ (inspect-for-emacs): Add CMUCL specific versions for array and
+ vectors.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp,
+ swank-clisp.lisp, swank-backend.lisp, swank-allegro.lisp,
+ swank-abcl.lisp (accept-connection): Accept :external-format as
+ argument.
+
+2004-11-19 Matthew Danish <mrd+nospam(a)cmu.edu>
+
+ * swank-allegro.lisp: (count-cr): New function. Convert
+ file-offsets to match Emacs' eol-conventions.
+ (find-definition-in-file): Use it.
+
+ * slime.el (slime-insert-xrefs): Display the multi-line label much
+ more cleanly.
+
+2004-11-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (thread-status): Decode the thread-state-slot
+ instead of returning ???.
+
+ * swank-allegro.lisp (swank-mop:slot-definition-documentation):
+ ACL 7 says documentation should have 2 args. So, pass t as second
+ argument.
+ (fspec-primary-name): Recurse until we have a symbol.
+ (allegro-inspect): New function. Mostly reverse engineered from
+ ACL's native inspector.
+ (inspect-for-emacs (t), inspect-for-emacs (function)): Use it.
+
+ * swank.lisp (inspect-for-emacs array): Use row-major-aref instead
+ of a displaced array. I hope that does the same.
+ (inspect-for-emacs integer): Ignore errors in
+ decode-universal-time. Negative values and, in SBCL, also small
+ values cannot be decoded.
+ (list-threads): Include the thread-id. Useful for SLIME debugging.
+
+ * slime.el (slime-list-threads, slime-thread-insert): Show the
+ thread-id.
+ (slime-thread-control-mode-map): Remove the binding for the
+ no-longer-existent slime-thread-goahead command.
+
+2004-11-18 Alexey Dejneka <adejneka(a)comail.ru>
+
+ * swank.lisp (inspect-for-emacs): Fix bug in handling of arrays
+ with fill-pointers.
+
+2004-11-15 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: The REPL commands ,quit and ,sayoonara are now
+ distinct. Previously Quit killed all Lisps an all buffers. The
+ new Quit command kills only the current Lisp.
+ (slime-quit-lisp): New function.
+ (repl-command quit): Use it. Don't delete all buffers.
+ (repl-command sayoonara): No longer an alias for ,quit.
+ (slime-connection-list-mode-map): Bind C-k to slime-quit-lisp.
+ (slime-communication-style): New connection variable.
+ (slime-use-sigint-for-interrupt): Is no longer a connection local
+ variable. It's derived from the new slime-communication-style.
+ (slime-inhibit-pipelining): New user option.
+ (slime-background-activities-enabled-p): New predicate to control
+ various background activities like autodoc and arglist fetching.
+ (slime-space, slime-autodoc-message-ok-p): Use it.
+ (slime-search-call-site): Use hints provided to search a call-site
+ in a defun. Useful for the show-frame-source command.
+ (slime-goto-source-location): Use it.
+ (slime-quit): Deleted, as it was broken. May come back later.
+ (slime-inspector-label-face, slime-inspector-value-face)
+ (slime-inspector-action-face, slime-reader-conditional-face):
+ Provide better defaults for Emacsen which don't support :inherited
+ faces.
+
+ * swank-backend.lisp (emacs-connected): Don't pass the stream as
+ argument. make-stream-interactive is a better place for setting
+ buffering options.
+
+ * swank-cmucl.lisp (emacs-connected): Install GC hooks to display
+ GC messages in the echo area.
+ (sos/misc :flush-output): There seem to be funny signal safety
+ issues if the dedicated output stream is not used. So, lets first
+ reset the buffer index before sending the buffer to the underlying
+ stream.
+
+ * swank-lispworks.lisp (frame-source-location-for-emacs): Pass the
+ function name of the next (newer) frame as a hint to Emacs. This
+ way we can highlight the call site in some cases, instead of the
+ entire defun.
+ (frame-location): Renamed from function-name-location. The
+ argument is now a dspec, not only a name. Also include hints for
+ Emacs.
+ (lispworks-inspect): Simplified from old code.
+ (inspect-for-emacs): Use it for also for simple functions.
+ (emacs-connected, make-stream-interactive): Move the
+ soft-force-output stuff to make-stream-interactive.
+
+ * swank-abcl.lisp (emacs-connected): Deleted. The default
+ implementation should be good enough.
+
+ * swank-sbcl.lisp (emacs-connected): Updated for new interface.
+
+ * swank-openmcl.lisp (emacs-connected, make-stream-interactive):
+ Move buffering stuff to make-stream-interactive.
+
+ * swank.lisp (defstruct connection): Add new slot:
+ communication-style for convenience.
+ (create-connection): Initialize the new slot.
+ (connection-info): Send the communication-style to Emacs.
+ (install-fd-handler, simple-serve-requests): Sending
+ :use-sigint-for-interrupt is no longer necessary.
+
+2004-11-11 Raymond Toy <raymond.toy(a)ericsson.com>
+
+ * slime.el (slime-activate-font-lock-magic): Add XEmacs support.
+ (slime-reader-conditional-face): New face.
+
+2004-11-10 Marco Baringer <mb(a)bese.it>
+
+ * swank-backend.lisp (definterface): Eliminate unused variable
+ received-args.
+ (emacs-connected, make-stream-interactive, condition-references,
+ condition-extras, buffer-first-change): Add (declare (ignore X))
+ for unused arguments in default implementations.
+ (inspect-for-emacs): Remove (declare (ignore)) for inexistent
+ variable inspection-mode. Added T qualifiers in method arguments.
+
+ * swank-openmcl.lisp (inspect-for-emacs): Use definterface so
+ SLIME knows we implement this.
+ (arglist function): Use ccl:arglist, not ccl::arglist-from-map.
+ (inspect-for-emacs): Added support for inspecting the uvector
+ objects under lisp datums.
+
+2004-11-09 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (features-for-emacs): New function to avoid
+ keyword/string confusion. Case doesn't matter since Emacs will
+ downcase them anyway.
+ (connection-info, sync-features-to-emacs): Use it. Should fix
+ highlighting bug reported by Edi Weitz.
+
+ * slime.el (slime-eval-feature-conditional): Convert AND, OR, and
+ NOT to lowercase keywords.
+ (slime-net-read3): Silly optimization: give char-after the offset
+ as argument to avoid save-excursion and forward-char.
+
+2004-11-07 Brian Downing <bdowning(a)lavos.net>
+
+ * slime.el (slime-fuzzy-explanation): Added line to describe
+ flags (:boundp, :fboundp, :macro, etc), which are now reported in
+ the fuzzy-completion output.
+ (slime-fuzzy-insert-completion-choice): Added flags.
+ (slime-fuzzy-choices-buffer): Added flags header.
+
+ * swank.lisp (fuzzy-completions): Changed docstring to describe
+ new flags in the completion results.
+ (convert-fuzzy-completion-result): New function to marshall the
+ results from the completion core into something Emacs is
+ expecting. Added flags.
+ (fuzzy-completion-set): Use the above.
+ (compute-completion): Removed.
+ (score-completion): Cleaned up a little bit.
+ (highlight-completion): Use destructive nstring-upcase.
+
+2004-11-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-easy-menu): Add item for
+ slime-update-indentation. Suggested by Lynn Quam.
+ (slime-severity-faceslime-show-note-counts)
+ (slime-most-severe, slime-choose-overlay-region): Handle
+ read-errors.
+ (slime-show-buffer-position): New function.
+ (slime-show-source-location): Use it.
+
+ * swank-backend.lisp (deftype severity): Add read-errors.
+
+ * swank-cmucl.lisp (severity-for-emacs): Special case read-errors.
+ (read-error-location): Add the offset to the buffer start.
+
+ * swank.lisp (assign-index): Avoid linear search.
+
+2004-10-30 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-source-path-parser.lisp (source-path-stream-position):
+ Bind *read-suppress* only as long as we skip over forms. The last
+ toplevel form in the path is read with *read-suppress* = nil
+ because in newer versions of CMUCL and SBCL read will return nil
+ if *read-suppress* is t.
+
+2004-10-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-clisp.lisp: Ups. Undo previous change.
+
+ * swank-clisp.lisp: Add workaround for CLISP's broken control
+ string parser.
+
+ * swank-cmucl.lisp (set-step-breakpoints): Handle breakpoints at
+ single-return points in escaped frames better. Previously we
+ tried to set a breakpoint at the current position and consequently
+ was only hit during the next call.
+ (inspect-for-emacs)[function]: Call the next method only for
+ funcallable instances.
+ (profile-report, profile-reset, unprofile-all): We have to use
+ eval because the macro expansion depends on the value of
+ *timed-functions*. Reported by Chisheng Huang.
+
+ * slime.el (slime-space): Call slime-message in the right buffer,
+ so that after-command hooks are added in the right buffer.
+ Reported by Juho Snellman.
+ (slime-dispatch-event): Accept stepping flag.
+ (sldb-setup): Don't query when entering a recursive edit.
+ (sldb-exit): Don't kill the buffer if we are in stepping mode.
+ (slime-inspector-insert-ispec): New function.
+ (slime-open-inspector): Use it.
+ (slime-inspector-operate-on-point): Simplified.
+ (test interactive-eval): Fix test case.
+ (slime-kill-all-buffers): More regexp kludges. From Bill Clementson.
+
+ * swank-backend.lisp (activate-stepping): New function.
+
+ * swank.lisp (*sldb-stepping-p*): New variable. Used to tell
+ emacs that the debugger buffer should not be closed even if we
+ unwind.
+ (debug-in-emacs): Use it.
+ (sldb-step): Moved to the front end.
+ (inspector-princ, method-specializers-for-inspect): Simplified.
+ (methods-by-applicability): Use a simpler algorithm. I doubt there
+ is much difference in practice.
+ (inspect-for-emacs)[symbol, function, standard-generic-function]
+ [standard-method]: Use less than 80 columns.
+ (inspector-call-nth-action): Don't accept &rest args. Was never
+ used.
+ (inspect-for-emacs) [integer]: Fix control string. Thanks to CSR
+ for pointing it out.
+
+2004-10-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-sbcl.lisp (signal-compiler-condition): Actually delete one
+ of the reader-conditionalized forms.
+
+2004-10-26 Helmut Eller <heller(a)common-lisp.net>
+
+ * cl-indent.el: Add indentation specs for some missing CL symbols.
+ (lisp-prefix-match-indentation): Change default to
+ nil to avoid confusion for people who don't care about the issue.
+
+ * swank-sbcl.lisp (signal-compiler-condition): Remove reader
+ conditionals as the current code doesn't work in any SBCL before
+ 0.8.13 anyway.
+
+ * swank-source-path-parser.lisp: Remove workarounds for SBCL bugs.
+ The bugs are fixed in the versions we support.
+
+ * swank-cmucl.lisp (read-error-location)
+ (signal-compiler-condition): Handle read-errors.
+ (swank-compile-file): Don't load the fasl file if there was an
+ error.
+
+ * swank.lisp (define-printer-variables): Handle doc strings
+ properly.
+ (*sldb-pprint-dispatch*): Initialize it with the default dispatch
+ table.
+
+ * slime.el (slime-init-command): New function to send the command
+ to load swank. Having a separate function for the task should
+ make it easier to start a Lips with a preloaded swank.
+ (slime-maybe-start-lisp): Use it.
+ (slime-maybe-start-multiprocessing): Deleted.
+ (slime-repl-buffer): Include the name of the implementation.
+ (slime-set-default-directory)
+ (slime-sync-package-and-default-directory): Translate filenames.
+
+2004-10-25 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (inspect-for-emacs array): Properly deal with arrays
+ without fill pointers.
+ (inspect-for-emacs function): Show function-lambda-expression
+ when available.
+
+ * swank-openmcl.lisp (specializer-name): New function.
+ (who-specializes): Use it.
+ (maybe-method-location): Use it.
+ (function-source-location): Use it.
+
+ * swank-cmucl.lisp (inspect-for-emacs function): Use next
+ method's values and simply add cmucl specific details.
+
+ * slime.el (slime-repl-defparameter): Change default value to "*".
+
+2004-10-25 Thomas Schilling <tjs_ng(a)yahoo.de>
+
+ * swank-allegro.lisp (inspect-for-emacs): Use
+ excl::external-fn_symdef to get the function documentation.
+
+ * swank.lisp (inspect-for-emacs): Order generic function's methods
+ and show abbreviated docs for methods.
+ (abbrev-doc): New function.
+ (methods-by-applicability): New function.
+ (*gf-method-getter*): New variable.
+
+2004-10-19 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-show-source-location): Call `push-mark' to push
+ the source position onto the global mark ring.
+
+2004-10-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank.lisp (define-printer-variables): NIL is not a valid
+ docstring. Reported by Alain Picard.
+ (printer-variables sldb-print): Include print-gensym,
+ pprint-dispatch, base, radix, array, and lines.
+
+2004-10-17 Luke Gorrie <luke(a)synap.se>
+
+ * slime.el (slime-message): Use slime-typeout-frame if available.
+
+2004-10-17 Helmut Eller <heller(a)common-lisp.net>
+
+ * cl-indent.el: Our local copy. Should eventually be merged the
+ file with in the main distribution.
+
+ * slime.el: (slime-find-buffer-package-function): New variable to
+ allow customization for unusal syntax.
+ (slime-maybe-rearrange-inferior-lisp): Removed unused function.
+ (slime-set-inferior-process): Non-macro version to make
+ byte-compiler happy. Reported by Raymond Wiker.
+ (slime-maybe-start-lisp): Use it.
+ (slime-sync-package-and-default-directory): Synch the
+ default-directory in the REPL buffer too.
+ (slime-goto-connection): Close the connection list window.
+ Suggested by Andras Simon.
+ (slime-repl-clear-buffer): Place point after the prompt.
+ (selector-method ?i): Use slime-process to switch to the right
+ buffer.
+ (slime-background-message): Do nothing if the minibuffer is
+ active.
+ (slime-indent-and-complete-symbol): Don't indent if we at the same
+ line as the prompt.
+
+ * swank.lisp (*sldb-pprint-frames*): Renamed to
+ *sldb-print-pretty*.
+ (*sldb-print-level*, *sldb-print-length*, *sldb-print-circle*)
+ (*sldb-print-readbly): Group of new variables to customize
+ printing in the debugger. The default values should be safe.
+ (define-printer-variables, with-printer-settings): New macros to
+ make defining and binding groups of printer variables easier.
+ (inspect-for-emacs-list): Fix bug with circular lists and only
+ shows the first 40 elements.
+ (inspect-for-emacs): Various cleanups.
+ (all-qualified-readnames): Removed. It was not needed because
+ common-lisp-indent-function strips of any package prefix and
+ downcases the symbol anyway.
+ (printer-variables sldb-print): Ooops. Better use sldb-print as prefix
+ than sldb alone. *sldb-level* was already defined.
+
+ * swank-cmucl.lisp (inspect-for-emacs (code-component)):
+ Disassemble the memory region if there's not enough debug info.
+
+2004-10-17 Jan Rychter <jan(a)rychter.com>
+
+ * swank-cmucl.lisp (return-from-frame): Add it.
+
+2004-10-11 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU>
+
+ * swank-sbcl.lisp (function-definitions): Find compiler macros, too.
+ (find-defintions, compiler-definitions)
+ (optimizer-definitions, transform-definitions): Add compiler
+ transformers and optimizers to the list of definitions.
+
+2004-10-07 Peter Seibel <peter(a)javamonkey.com>
+
+ * swank.lisp (spawn-threads-for-connection): Bind *debugger-hook*
+ instead of SETF'ing it.
+
+2004-10-06 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (update-indentation/delta-for-emacs): Configure Emacs
+ indentation settings not just for the symbol name but for all
+ package-qualified forms of it as well.
+
+ * doc/slime.texi (Credits): Updated the credits list to include
+ more Lisp implementors who're also SLIME hackers.
+
+2004-10-05 Luke Gorrie <luke(a)synap.se>
+
+ * swank.lisp (arglist-for-echo-area): Handle errors and return a
+ message.
+ (parse-symbol): Recognise an empty package name as the KEYWORD
+ package.
+
+2004-10-03 Reini Urban <rurban(a)x-ray.at>
+
+ * swank-clisp.lisp (getpid)[win32]: Use
+ win32:|GetCurrentProcessId|.
+
+2004-10-03 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el: Reduce dependency on inf-lisp internals. Make it
+ possible to start the inferior lisp in a buffer different from
+ "*inferior-lisp*".
+ (slime): Parse the command argument explicitly and don't rely on
+ `inferior-lisp'. Don't close all connections, but only the one
+ for the inferior lisp buffer we are using.
+ (slime-maybe-start-lisp): Take the command and buffer as argument.
+ Decide here whether we should start start a new processwe or just
+ disconnect and reconnect .
+ (slime-start-lisp): Load verbosely.
+ (slime-inferior-lisp): New function. Replaces call to
+ `inferior-lisp'.
+ (slime-inferior-connect, slime-start-swank-server): Take the
+ inferior process as argument
+ (slime-read-port-and-connect): Set the slime-inferior-process
+ variable in the new connection.
+ (slime-inferior-process): New connection local variable.
+ (slime-process): Use it.
+ (slime-restart-inferior-lisp): Don't use inferior lisp stuff.
+ (slime-switch-to-output-buffer): Process interactive arguments
+ properly.
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Load
+ verbosely.
+
+2004-10-01 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-allegro.lisp (find-fspec-location): excl:source-file can
+ return stuff like (:operator ...); try to handle it.
+
+ * swank-cmucl.lisp (code-component-entry-points): Only include
+ entry points with "valid" functions names. This excludes internal
+ lambdas which have usually a string as name, like "defun foo".
+
+ * swank.lisp (parse-symbol): Don't use the reader to avoid
+ interning unknown symbols. The downside is that we no longer
+ handle escaped |symbols| correctly.
+
+ * slime.el (slime-set-connection-info): Hide the *inferior-lisp*
+ buffer after we know Lisp's pid. Print the words of encouragement
+ here, when all the other asynchronous initialization is completed.
+ (slime-find-buffer-package): We need to preserve the case for
+ things like (:in-package "foo"), so return "\"foo\"".
+
+2004-09-27 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-process): New function intended to replace all
+ those references to the *inferior-lisp* buffer.
+ (slime-maybe-start-lisp): Split it up.
+ (slime-start-lisp): New function.
+ (slime-restart-inferior-lisp): Use the command from the existing
+ process to start the new process.
+
+2004-09-27 Christian Lynbech <christian(a)defun.dk>
+
+ * slime.el (define-slime-dialect): New macro to make starting
+ Lisps with different command line options easier.
+
+2004-09-27 Rui Patroc�nio <rui.patrocinio(a)netvisao.pt>
+
+ * swank.lisp (mop, mop-helper): Support functions for the class
+ browser.
+
+ * slime.el (slime-browse-classes, slime-browse-xrefs): New
+ commands to browse class hierarchies and xref graphs in a tree
+ widget.
+
+ * tree-widget.el: New file. Only needed for older Emacsen.
+
+2004-09-23 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime.el (slime-start-and-load): Take arguments so that the
+ function can be called non-interactively. Only start SLIME is if
+ it is not running.
+ (slime-recompile-bytecode): Don't warn about uses of cl-functions.
+ (slime-reset): Kill all sldb buffers.
+ (slime-goto-location-position): Fix syntax for Emacs 20.
+ (sldb-mode-map): Add C-c C-d bindings.
+ (slime-open-inspector): Insert the type in the second line so that
+ we can make longer titles, e.g we should include the princed
+ version of the inspected object.
+
+ * swank-backend.lisp (frame-package, label-value-line)
+ (label-value-line*): New functions.
+
+ * swank.lisp (frame-locals-for-emacs): Bind *print-pretty* to
+ *sldb-pprint-frames* to get more compact lines and bind *package*
+ to frame-package to get shorter labels for variables.
+ (format-values-for-echo-area): Include the hex and octal
+ representation for integers.
+ (apply-macro-expander, disassemble-symbol): Use the buffer-package
+ for reading.
+ (inspector-content-for-emacs): Use print-part-to-string so that we
+ see cycles in the data structure.
+ (inspect-for-emacs): Minor beautifications.
+ (load-file-set-package): New function.
+
+ * swank-cmucl.lisp (frame-package): Implemented.
+ (inspect-for-emacs): Only include stuff that is actually stored in
+ the object itself (see objdef.lisp for exact object layout).
+ Include the disassembly for functions and code components.
+
+2004-09-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-gray.lisp (stream-read-char): Treat empty strings as
+ end-of-file.
+
+ * swank-cmucl.lisp (sis/in): Treat empty strings as end-of-file.
+ (map-allocated-code-components): Inhibit efficiency notes.
+ (arglist)[symbol] Delete unreachable code.
+ (sldb-break-on-return, sldb-break-at-start): Implement it
+ (sldb-step): Some cleanups.
+
+ * swank.lisp (thread-for-evaluation): Restart the listener thread
+ if it was dead for some reason.
+ (debugger-condition-for-emacs): Include "extra" stuff. Currenlty
+ only used to pop up the source buffer at breakpoints.
+ (sldb-break): New function.
+ (interrupt-worker-thread): Interrupt the repl thread if there is
+ no other active thread.
+
+ * swank-backend.lisp (import-swank-mop-symbols): New
+ function. Useful if the implementation has most of the mop symbols
+ in the same package.
+ (sldb-break-on-return, sldb-break-at-start, condition-extras): New
+ functions.
+
+ * slime.el (sldb-break-on-return, sldb-break): New commands.
+ (slime-repl-return-string): Allow empty strings. That's our way
+ to send end-of-file.
+ (sldb-insert-condition): Add "extra" slot for random thing that
+ don't fit nicely somewhere else.
+ (sldb-dispatch-extras): New function.
+ (sldb-show-frame-source): New non-interactive version of
+ sldb-show-source.
+ (sldb-show-source): Use it.
+ (slime-beginning-of-symbol, slime-end-of-symbol): New functions
+ which don't include the character after a hash '#'.
+ (slime-symbol-name-at-point): Use them.
+ (slime-symbol-start-pos, slime-symbol-end-pos): Ditto.
+
+2004-09-17 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp: Don't print "Documentation:" if none is available;
+ add support for classes specializer-direct-methods; deal with
+ eql-specializers in methods.
+ (inspector-princ): New function.
+ (method-specializers-for-inspect): New function.
+ (method-for-inspect-value): New function.
+ (inspect-for-emacs): Use inspector-princ instead of
+ princ-to-string.
+
+ * swank-backend.lisp (swank-mop): Require eql-specializer,
+ eql-specializer-object and specializer-direct-methods in swank-mop
+ package.
+
+ * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp,
+ swank-openmcl.lisp, swank-sbcl.lisp (swank-mop): Export
+ eql-specializer, eql-specializer-object and
+ specializer-direct-methods from swank-mop.
+
+ * swank-cmucl.lisp (inspect-for-emacs): Thinko fix.
+
+ * swank-lispworks.lisp (swank-mop): Export
+ specializer-direct-methods.
+ (eql-specializer): Implement.
+ (eql-specializer-object): Implement.
+
+ * swank-sbcl.lisp (inspect-for-emacs): Fix broken ignore
+ declaration.
+
+ * doc/slime.texi: Update inspector documentation.
+
+2004-09-16 Marco Baringer <mb(a)bese.it>
+
+ * swank-clisp.lisp (swank-mop, inspect-for-emacs): Only define the
+ CLOS parts of the inspector if the underlying lisp provides the
+ required functionality. If not enough MOP is present to implement
+ the inspector then we define some very simple replacement methods.
+
+2004-09-16 Marco Baringer <mb(a)bese.it>
+
+ * swank-clisp.lisp (swank-mop): Implement the MOP compatability
+ package.
+ (inspect-for-emacs): Update for new inspection API.
+
+2004-09-15 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-openmcl: typo in who-references. Fix frame-var-value
+
+2004-09-15 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-inspector-label-face,
+ slime-inspector-value-face, slime-inspector-action-face,
+ slime-inspector-type-face): These faces now inherit from similar
+ font-lock-<whatever> faces.
+ (slime-open-inspector): Use slime-inspector-value-face for values.
+
+ * swank.lisp (inspect-for-emacs): Add function and compiler-macro
+ documentation when inspecting symbols. View the truename of
+ logical pathnames where they exist. Fix typos in package
+ inspector (fix by Torsten Poulin <torsten(a)diku.dk>).
+
+ * swank-sbcl.lisp, swank-cmucl.lisp (inspect-for-emacs): Insert
+ function object's documentation when it's available.
+
+2004-09-15 Eduardo Mu�oz <emufer(a)terra.es>
+
+ * .cvsignore: Added *.elc
+
+ * hyperspec.el: Fixed syntax error.
+
+2004-09-15 Alan Caulkins <fatman(a)maxint.net>
+
+ * swank.lisp (cleanp-connection-threads): Kill all Swank threads
+ for a connection when it terminates.
+
+2004-09-14 Thomas Schilling <tjs_ng(a)yahoo.de>
+
+ * swank-allegro.lisp (inspect-for-emacs): Fixes to previous patch.
+
+2004-09-14 Marco Baringer <mb(a)bese.it>
+
+ * swank-backend.lisp (inspector, make-default-inspector): Add an
+ INSPECTOR object argument to the inspector protocol. This allows
+ implementations to provide more information regarding cretain
+ objects which can't be, or simply aren't, inspected using the
+ generic inspector implementation. also export inspect-for-emacs
+ and related symbols from the backend package.
+ (make-default-inspector): New function.
+
+ * swank.lisp (inspected-parts): Rename to inspect-for-emacs and
+ add an inspector argument. Move inspect-for-emacs to
+ swank-backend.lisp, leave only the default implementations.
+
+ * swank-openml.lisp, swank-sbcl.lisp, swank-allegro.lisp,
+ swank-cmucl.lisp, swank-lispworks.lisp (inspected-parts): Rename
+ and change argument list. Many of the inspected-parts methods were
+ being clobbered by the inspected-parts in swank.lisp, now that
+ they're being used the return values have been updated for the new
+ inspect-for-emacs API.
+
+2004-09-14 Thomas Schilling <tjs_ng(a)yahoo.de>
+
+ * swank-allegro.lisp (inspected-parts): Implement inspector for
+ structs.
+
+2004-09-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (intern-catch-tag): New function.
+ (read-user-input-from-emacs, take-input): Use it.
+
+2004-09-13 John Paul Wallington <jpw(a)gnu.org>
+
+ * swank.lisp (define-special): Make the doc-type `variable'
+ rather than `symbol'. Don't quote `doc'. Doc fix.
+
+2004-09-09 Martin Simmons <martin(a)xanalys.com>
+
+ * swank-lispworks.lisp: Set up the swank-mop package. Implement
+ swank-mop:slot-definition-documentation and function-name.
+
+2004-09-13 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (inspected-parts): Added inspectors for pathnames,
+ logical pathnames, standard-objects and numbers (float, ratio,
+ integer and complex).
+
+ * swank-backend.lisp: Define import-to-swank-mop.
+
+ * swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: Don't
+ define the import-to-swank-mop function (now defined in
+ swank-backend.lisp).
+
+ * swank-cmucl.lisp (swank-mop, function-name): Implement backend
+ for inspector.
+ (arglist): Add support for extracting arglists from function
+ objects.
+ (create-socket): Don't specify the host on PPC.
+
+2004-09-13 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * slime.el slime-goto-location-position: New location specifiers:
+ (:method name specializers . qualifiers) all are strings. Looks
+ for defxxx name then the qualifiers as words, in order then the
+ specializers as words, in order (except for "T", which is
+ optional). Pass the symbols names for specializers and qualifiers
+ (no packages). Used by openmcl but might be useful for others
+ (:text-anchored <position fixnum> <string> <delta fixnum>)
+ Got to position, then search for string, then move delta. To
+ support upcoming source recording for openmcl debugging.
+
+ * swank-openmcl multiple changes: - fix support for *sldb-top*
+ (formerly *swank-debugger-stack-frame*) Was not thread safe. Now
+ (application-error), and (interrupt-thread) records the error
+ pointer in a table associated with thread and map-backtrace picks
+ up the appropriate pointer. *process-to-stack-top*,
+ (grab-stack-top), (record-stack-top).
+
+ - Other adjustments for changes to multiprocessing: remove
+ (force-break-in-listener) no longer necessary since we use
+ process-interrupt instead of ccl::*interactive-abort-process*
+ Adjust break-in-sldb to do so for swank repl connections
+ (abstraction breaking reference to swank::*connections*, but
+ nicely via intern)
+
+ - changes to (find-definitions) (function-source-location),
+ addition of (maybe-method-location) (remove-filename-quoting). To support
+ editing definitions of methods. To fix bug with pathnames with
+ quoted characters (like "\\.swank.lisp"). To remove bogus source
+ recording of l1-boot-3 in functions that didn't have a source file
+ noted.
+
+ - Implementation of xref functions: (xref-locations) uses xref
+ implementation added to openmcl recently. Note that you have to
+ (ccl::start-xref) for it to work for other than who-calls, and
+ that xref information is not currently persisted in fasl files (I
+ will release a patch for this soon) Backend functions (who-binds)
+ (who-macroexpands) (who-references) (who-sets)
+ (who-calls) (list-callees) (who-specializes)
+
+ - Lifted profile backend functions from swank-clisp which use
+ "metering.lisp"
+
+ - (openmcl-set-debug-switches) turns on the various variables I.
+ know about that have the lisp record extra debugging
+ information(including starting xref). I suggest you call
+ it. Should it be called by default?
+
+ - (frame-arguments) use builtin ccl::frame-supplied-args since the
+ current version was sometimes missing the first argument to the
+ function. (I think this was when it was passed by register. If you
+ don't want to lose it in the frame locals in backtrace, call
+ (openmcl-set-debug-switches) specifically, set
+ ccl::*ppc2-compiler-register-save-label* to t
+
+ - implement frame-var-value backend
+
+ * metering.lisp: Minor changes to #+ #- to recognize openmcl
+
+ * swank-loader.lisp: Load "metering.lisp"
+
+2004-09-13 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (inspected-parts): Deal with unfinalized classes in
+ standard-class inspector. (Patch from Thomas Schilling)
+
+2004-09-13 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp: New inspector protocol. The lisp side now returns a
+ specially formated list of "things" to format which are then
+ passed to emacs and rendered in the inspector buffer. Things can
+ be either text, recursivly inspectable values, or functions to
+ call.
+ (inspected-parts): Redefine for new inspector protocol.
+ (*inspectee-parts*): Redefine as array.
+ (*inspectee-actions*): New array, similar to *inspectee-parts*.
+ (reset-inspector): Update for new implementation of
+ *inspectee-parts* and new variable *inspectee-actions*.
+ (inspector-contents-for-emacs): New function.
+ (inspect-object): Update for new inspector protocol.
+ (inspector-nth-part): Update for new *inspectee-parts*
+ implementation.
+ (inspector-call-nth-action): New function.
+
+ * slime.el (slime-inspector-action-face): New face.
+ (slime-open-inspector): Adapt to new inspector protocol.
+ (slime-inspector-operate-on-point): New function, subsumes
+ slime-inspector-inspect-object-at-point.
+ (slime-inspector-next-inspectable-object): Skip to next object,
+ not just end of current object; wrap around buffer.
+ (slime-inspector-mode-map): change bindings of [return] and "\C-m"
+
+ * swank-bacend.lisp (swank-mop): New package. Simply defines all
+ the MOP related symbols we need from an implementation.
+ (arglist): Update doc string. Provide default implementation.
+ (function-name): New backend function.
+
+ * swank-allegro.lisp (swank-mop, slot-definition-documentation):
+ Implement. (Patch from Thomas Schilling)
+
+ * swank-sbcl.lisp (swank-mop, slot-definition-documentation,
+ function-name): Implement.
+
+ * swank-openmcl.lisp (swank-mop, function-name): Implement.
+ (arglist): Implement for function objects.
+
+2004-09-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (compile-file-for-emacs): Use with-buffer-syntax so
+ that SBCL source files can be compiled. From Christophe Rhodes.
+
+2004-09-09 Martin Simmons <martin(a)xanalys.com>
+
+ * swank-loader.lisp (make-swank-pathname): Preserve the host
+ component (important for LispWorks on Windows).
+
+2004-09-08 Martin Simmons <martin(a)xanalys.com>
+
+ * swank-lispworks.lisp: Implement call-with-compilation-hooks.
+
+2004-09-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * NEWS: Summarize changes since August.
+
+ * slime.el: Add some docstrings.
+
+ * mkdist.sh: Add PROBLEMS file. We're no longer alpha.
+
+ * swank.lisp: Remove debugging code in comment.
+
+ * swank-sbcl.lisp: Delete dead code.
+
+ * swank-lispworks.lisp (defimplementation): define-dspec-alias
+ seems to more apropriate than define-form-parser.
+
+ * swank-cmucl.lisp (print-frame): Catch errors during printing.
+
+ * README: Fix typo.
+
+2004-09-02 Wolfgang Mederle <wolfgang.mederle(a)stud.uni-muenchen.de>
+
+ * swank-loader.lisp (*lisp-name*): Replace / with - in CMUCL
+ version strings.
+
+2004-09-01 John Paul Wallington <jpw(a)gnu.org>
+
+ * slime.el (slime-oneliner): Don't use free variable.
+ (slime-recenter-window, slime-set-connection-info)
+ (slime-pprint-event, slime-compiler-notes-quit)
+ (slime-apropos-summary): Likewise.
+ (slime-connect): Tidy up handshake `message' call.
+
+2004-09-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-repl-push-directory): Fix interactive spec.
+ (sldb-reference-properties): Take a the reference object as
+ argument instead of its parts. Fix callers accordingly.
+ (slime-fuzzy-choices-buffer): Remove assignment to unused variable
+ slime-fuzzy-target-mtime.
+ (slime-ed): Replace call to new-frame with make-frame.
+ (sldb-find-buffer): Cleanup.
+ (sldb-highlight-sexp): Fix regexp. It's now almost a full line.
+
+ * swank.lisp (completion-set, tokenize-symbol-designator)
+ (tokenize-completion, fuzzy-completion-set)
+ (briefly-describe-symbol-for-emacs): Remove simple-base-string
+ declarations.
+
+2004-08-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * PROBLEMS: We require SBCL 0.8.13. 0.8.12 is no longer
+ supported.
+
+ * swank-allegro.lisp (find-fspec-location): Catch errors in
+ excl:source-file.
+
+ * swank.lisp (send-to-socket-io): Add some ignore declarations.
+
+ * slime.el (sldb-fetch-all-frames, sldb-end-of-backtrace)
+ (sldb-beginning-of-backtrace): New commands.
+ (slime-search-suppressed-forms): Change the start regexp so that
+ reader conditionals in single line comments, like "; #+foo", are
+ ignored.
+
+2004-08-27 Peter Seibel <peter(a)javamonkey.com>
+
+ * swank-backend.lisp (swank-compile-string): Add directory
+ argument which is used by Allegro backend to improve source
+ recording for definitions compiled with C-c C-c.
+
+2004-08-23 John Paul Wallington <jpw(a)gnu.org>
+
+ * slime.el (slime-pretty-package-name): Fix last cond clause.
+
+2004-08-21 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (*global-debugger*): New configurable to globally
+ install swank-debugger-hook as *debugger-hook*. True by default.
+
+2004-08-19 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/slime.texi: C-c C-c C-a, C-c C-u C-e.
+ Thanks Barry Fishman for reporting incorrect indexing.
+
+2004-08-18 Matthew Danish <mrd+nospam(a)cmu.edu>
+
+ * swank-allegro.lisp (swank-compile-string): Use #\; instead of
+ #\: to separate the position from the buffer-name. This avoids
+ troubles on Windows.
+
+2004-08-16 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/slime.texi: Random updates.
+
+ * slime.el (slime-space): Use slime-message instead of
+ slime-background-message. This displays multi-line arglists.
+ (sldb-mode-map): Bind 'C' to sldb-inspect-condition.
+
+2004-08-14 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-find-buffer-package): Use "%s", not "%S", to
+ avoid ugly escape characters, if the package name contains dots.
+
+2004-08-13 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-eval-in-frame): Print result to the REPL when a
+ prefix argument is given.
+ Added pull-down menus for SLDB and the REPL.
+
+ * swank-source-path-parser.lisp: Removed caching of readtables and
+ the source-map hashtable. Fresh creation is ultra-cheap (<1ms).
+ The caching didn't handle modifications to readtables and
+ generally made me feel uneasy while tracking down an obscure bug
+ in a reader macro.
+ The cached source-map hashtable also wasn't thread-safe (ho hum).
+
+2004-08-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-merge-notes, slime-tree-for-note): Use the short
+ note message for annotation in the source buffer and the long
+ message in the tree widget. Used to be the other way around.
+ (sldb-insert-frames): Set the `start-open' property for XEmacs.
+ Without `start-open', the `point-entered' property is inherited
+ when we insert something before the "--more--" marker. Reported
+ by Sundar Narasimhan.
+
+ * swank.lisp (variable-desc-for-echo-area): Bind some printer
+ variables to limit the length of the output.
+
+2004-08-05 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-setup): Added typeout-frame keyword argument.
+ (slime-thread-attach): Fixed misnamed function call.
+
+2004-08-04 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-allegro.lisp (find-fspec-location): Fixed to work for more
+ types of definition than just functions. So M-. now works for e.g.
+ classes in Allegro. From Matthew Danish.
+ (find-fspec-location): Include the type of the definition in the
+ designator sent to Emacs. From Matthew Danish.
+
+2004-08-04 Martin Simmons <martin(a)xanalys.com>
+
+ * swank-lispworks.lisp (frame-actual-args): Correct syntax for
+ handler-case.
+
+2004-08-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: (slime-mode-map, slime-repl-mode-map)
+ (slime-repl-read-mode-map): Remove the binding for C-c C-g. C-c
+ C-b is now the default interrupt key.
+ (slime-list-repl-short-cuts): Don't trash the shortcut-table: copy
+ it before sorting. (Thanks to Mark Simpson.)
+
+2004-08-02 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-connect): Shorten the welcome message by leaving
+ out the port number (which is displayed in the REPL anyway). This
+ avoids line-wrapping some messages of encouragement.
+
+ * swank.lisp (with-buffer-syntax): Don't bind *readtable* to
+ *buffer-readtable* if they are already EQ. When we shadow this
+ binding the user can't assign *readtable* from the REPL so it's
+ best avoided when possible.
+
+ * swank-allegro.lisp: Removed fwrapper-based code for inheriting
+ "swankiness" to newly spawned threads. This was fighting the
+ system and not the right thing.
+
+ * slime.el (slime-choose-overlay-region): Tweaked the
+ multiline-annotation-avoidance code to work with forms not
+ starting with an open-paren, e.g. `(..) or #'(..).
+ (slime-update-modeline-package): New configurable. Non-nil (the
+ default) means update the Lisp package in the modeline using an
+ idle timer.
+ (slime-repl-send-input): Make the `slime-repl-old-input' property
+ cover the whole input (including newline) so that pressing RET on
+ the end of an input line works.
+ Use a unique integer as the value of this property to distinguish
+ adjacent inputs.
+ (slime-current-package): Deal with narrowing.
+
+2004-08-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp (swank-compile-string): Use a temporary file
+ and set excl::*source-pathname* manually. This way we can find
+ the source buffer of functions compiled with C-c C-c.
+ (call-with-temp-file, compile-from-temp-file): New functions.
+ (list-callers, function-callers, in-constants-p)
+ (map-function-constants): Implements list callers by groveling
+ through the constants pools of named functions.
+
+ * swank-lispworks.lisp: Minor refactoring.
+
+2004-07-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-connection): Say "No default connection
+ selected" if there are open connections but no default connection.
+ (slime-tree-indent-item): Point wasn't updated correctly if the
+ last line was empty. Use insert-before-markers instead of insert
+ to do it properly.
+ (slime-draw-connection-list): Don't break if there is no default
+ connection.
+
+ * swank-cmucl.lisp (call-with-debugging-environment): Only handle
+ DI::UNHANDLED-CONDITION not all DI:DEBUG-CONDITIONs.
+
+ * swank-backend.lisp (sldb-condition): Show the original condition
+ in the message.
+
+2004-07-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-eval-feature-conditional): Treat uppercase
+ operators NOT, AND, OR correctly.
+ (sldb-find-buffer): Remove killed buffers.
+ (sldb-quit): Raise an error if the RPC returns.
+ (slime-expected-failures): Delete unused function.
+ (complete-symbol): Test completion of
+ swank::compile-file. LispWorks has extra completions for
+ cl::compile-file.
+ (arglist): Test arglist of method cl:class-name. Add enough
+ regexpery to pass the test in most implementations.
+
+ * swank-sbcl.lisp (list-callers, list-callees): Implemented.
+
+2004-07-26 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-first-change-hook): Add `save-match-data' to
+ avoid breaking e.g. query-replace. Also added `save-excursion'
+ just to be safe.
+
+ * README: s/setup-slime/slime-setup/ in the .emacs snippet.
+
+2004-07-23 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-set-state): Show the message in the modeline in
+ the case where we aren't connected. Otherwise the "not connected"
+ status is ignored.
+ (slime-net-sentinel): Close the connection before changing the
+ status message. The old behaviour of this combined with the old
+ behaviour of `slime-set-state' could generally cause spurious
+ errors after a connection was closed.
+
+2004-07-22 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (carefully-find-package): Return *BUFFER-PACKAGE* if
+ no other package can be found. This is reverting a previous change
+ that broke completion in buffers with no known package.
+
+ * slime.el (slime-maybe-start-lisp): Check that *inferior-lisp*
+ exists /and/ has a running process. Fixes a startup problem if
+ your inferior-lisp has died and you want to restart SLIME.
+
+2004-07-21 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-sync-package-and-default-directory): Sync
+ `default-directory' in the REPL buffer too.
+ (slime-set-state): Convenience function for setting a connection's
+ state-name and updating the modeline if appropriate. This function
+ is called in the right places.
+ (slime-to-lisp-filename): Use `expand-file-name'.
+
+2004-07-20 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-repl-update-banner): Restore old behaviour of
+ using an asynchronous evaluation to setup the REPL. This works
+ around a problem I'd reintroduced where the first REPL command
+ uses the wrong keymap.
+
+2004-07-20 Andreas Fuchs <asf(a)boinkor.net>
+
+ * swank-sbcl.lisp (call-with-compilation-hooks): Trap and report
+ errors that cause compilation to fail, e.g. read errors.
+
+2004-07-19 Luke Gorrie <luke(a)bluetail.com>
+
+ * HACKING: Updated. Some notes about Emacs features.
+
+ * slime.el: More major refactoring.
+ Restructured and documented the networking and protocol code.
+ (slime-rex-continuations): Now connection-local.
+
+2004-07-18 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el: Major refactoring.
+ Mostly resectioning and reordering definitions to try and improve
+ readability.
+ (slime-get-temp-buffer-create): New utility function to popup a
+ temporary buffer that automatically has a binding on `q' to
+ intelligently restore window configuration. Handy, but currently
+ not applicable to all of our temporary buffers.
+ (slime-with-chosen-connection): Removed this macro. Consequently
+ the compilation commands no longer prompt for which connection to
+ use when given a prefix argument. `slime-switch-to-output-buffer'
+ still works like that, but for other cases I think the
+ connection-list buffer is sufficient.
+ (slime-eval-async): New arglist: (form &optional cont pkg). If the
+ continuation is unspecified then the evaluation result is ignored,
+ and if the package is unspecified then (slime-buffer-package) is
+ used.
+ (slime-eval): Package arg now defaults to (slime-buffer-package).
+ (slime-current-package): New name for (slime-buffer-package). No
+ more caching: returns the buffer-local `slime-buffer-package' if
+ set, otherwise searches for an `in-package' form.
+ A consequence of non-caching is that the package name doesn't
+ appear in the modeline anymore. The simplification is worthwhile
+ in my opinion.
+
+2004-07-17 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-autodoc): If there is a global variable name at
+ point then show its value.
+ (slime-autodoc-cache-type): Cache type 'full is no longer
+ supported.
+ (slime-background-message): Truncate messages to fit on a single
+ echo area line.
+ (slime-repl-update-banner-p, slime-dont-prompt)
+ (slime-swank-connection-retries): Removed these unused or unuseful
+ configuration variables.
+ Rearranged organised "customize" groups.
+
+ * swank.lisp (variable-desc-for-echo-area): New function.
+ (arglist-for-echo-area): Return nil if symbol can't be found.
+ (close-connection): Close connection before printing error
+ message. This avoids it getting lost in closed I/O redirection.
+
+ * README, doc/slime.texi: Updated setup instructions.
+
+2004-07-16 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-conservative-indentation): New variable. When
+ true (the default) don't auto-learn indentation of def* and with-*
+ macros. Set to nil if you want to learn them.
+ (slime-handle-indentation-update): Use it.
+
+ * swank.lisp (known-to-emacs-p): Removed filtering of def* and
+ with-*. Now handled by Emacs.
+
+ * slime.el (slime-interactive-eval): Changed display of results.
+ By default the result goes to `slime-message', which leads either
+ to echo area, temporary buffer, or typeout frame.
+ With a prefix argument the result is printed to the REPL.
+ This goes for all commands based on slime-interactive-eval, e.g.
+ `C-x C-e' and `C-c M-:'.
+
+2004-07-16 Peter Seibel <peter(a)javamonkey.com>
+
+ * slime.el (package-updating): Fixing this and other tests I broke
+ with my change to how emacs keeps track of the package prompt
+ string.
+ (arglist): Fix an test failure under Allegro due to a slight
+ difference in the way EXCL:ARGLIST returns arglist (no default
+ values of &optional parameters)
+
+2004-07-16 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (print-connection): print-function for connection
+ objects. Dumping the indentation-cache was damned ugly with
+ non-truncated lines (e.g. bug reports on slime-devel).
+
+ * slime.el (slime-setup): New function for installing a
+ lisp-mode-hook. You can call this from ~/.emacs to setup SLIME.
+ Takes a `autodoc' keyword argument to enable
+ slime-autodoc-mode. We can add more keywords in future.
+ (slime-keys): Moved `slime-reindent-defun' from C-M-q to
+ C-cM-q. This avoids overriding the standard binding of C-M-q to
+ index-sexp.
+ (slime-typeout-frame-properties): Removed some properties:
+ `name', because it interacts badly with X properties, `left' and
+ `top' because they don't put the frame anywhere terribly
+ convenient, and (width . 40) because it makes the frame narrower
+ than the usual word-wrapping width.
+
+2004-07-14 Peter Seibel <peter(a)javamonkey.com>
+
+ * slime.el (slime-lisp-package-prompt-string): Separate SLIME's
+ notion of package into two parts, an actual package name and the
+ name used in the prompt since the latter isn't necessarily an
+ actual package nickname any more.
+
+2004-07-13 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-restart-inferior-lisp): Renamed shortcut to
+ "restart-inferior-lisp" from "restart-lisp". The name better
+ suggests what it does: kill *inferior-lisp* and rerun SLIME.
+
+2004-07-13 Eric Blood <eblood(a)winkywooster.org>
+
+ (slime-inspector-next-inspectable-object): New inspector command
+ to goto the next inspectable object (slot). Bound to TAB.
+
+2004-07-13 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * slime.el: add support for actionable references in the
+ *slime-compiler-notes* buffer.
+ (slime-merge-notes): merge references if applicable.
+ (slime-compiler-notes-mode-map): use new functions defaulting to
+ show-details, but overrideable by text properties.
+ (slime-tree-default-printer): destroy generality by assuming a
+ tree of conditions, and insert references if applicable.
+ (sldb-format-reference-source): add :amop
+
+ * swank-sbcl.lisp (signal-compiler-condition,
+ brief-compiler-message-for-emacs,
+ long-compiler-message-for-emacs): handle references in compiler
+ conditions.
+
+ * swank.lisp (make-compiler-note): propagate references.
+
+ * swank-backend.lisp (compiler-condition): add references slot.
+
+2004-07-12 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-easy-menu): Added "Apropos all" menu item.
+ (slime-restart-lisp): Added `restart-lisp' shortcut. Doesn't do
+ the right thing if you have multiple Lisps up.
+
+ * swank.lisp: Added some docstrings.
+ Rearranged completion code and somewhat SLDB trying to layout
+ functions above their subfunctions in a tree-like way.
+ (slime-protocol-error): Renamed from slime-read-error.
+ (carefully-find-package): Now returns NIL if package can't be
+ determined, rather than *BUFFER-PACKAGE*. Correct? I didn't see
+ why it should return *BUFFER-PACKAGE*.
+ (xref): Find symbol in *BUFFER-PACKAGE*.
+
+2004-07-09 Peter Seibel <peter(a)javamonkey.com>
+
+ * swank.lisp (package-string-for-prompt): Change the way package
+ name in prompt is computed. N.B. after this change the name
+ displayed will not necsarily be either an actual name or nickname
+ of the package: if the name contains dots by default the prompt
+ will only display the last element, i.e. COM.GIGAMONKEYS.SPAM will
+ be shown as SPAM. This change also makes CL-USER the canonical
+ name for COMMON-LISP-USER even in implementations that provide a
+ shorter nickname such as USER.
+
+2004-07-09 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * slime.el (sldb-lookup-reference): substitute hyphens for spaces
+ in the url.
+
+2004-07-07 Thomas Schilling <tjs_ng(a)yahoo.de>
+
+ * swank.lisp (arglist-for-insertion): Changed formatting to use
+ arglist-to-string. That results in proper cases for
+ slime-insert-arglist.
+
+2004-07-07 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-loader.lisp (*lisp-name*): Include the version number in
+ ACL.
+
+ * slime.el (slime-alistify): Preserve order. This keeps the
+ *compiler-notes* right. Pointed out by Christophe Rhodes.
+ (slime-repl-update-banner-p): Renamed from slime-reply-..
+ (slime-changelog-date): Reintroduced for informational purposes.
+ (slime-repl-update-banner): Show ChangeLog date in the animation.
+ (slime-space): Do arglist lookup before inserting the
+ space. Otherwise we get a funky race condition: entering the space
+ may trigger `first-change-hook', which would send an async
+ notification to Lisp, which would put us in the 'busy' state and
+ thus we wouldn't lookup the arglist! Detective work by Edi Weitz.
+ (sldb-prune-initial-frames): More regexp fudgery :-(.
+ (read-directory-name): Use `file-name-as-directory' to ensure we
+ have the trailing / on the directory name.
+ (byte-compile-warnings): Bye-compile slime-alistify. Its inputs
+ can be pretty big.
+
+2004-07-04 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el, swank-backend.lisp, swank.lisp: Added a new backend
+ function `buffer-first-change' which is called via Emacs's
+ `first-change-hook' in slime-mode buffers. This gives Lisp a
+ chance to do something with source files before you change them on
+ disk.
+
+ * swank-cmucl.lisp (buffer-first-change): Suck the source file
+ into the cache unless already present. This is for M-. to increase
+ the chances of our having a copy of the sources corresponding with
+ the loaded code. Should help with the case where a user edits and
+ saves a file (without recompiling it) and then M-.'s for one of
+ its definitions.
+
+ * swank-allegro.lisp (make-process/inherit): Changed reader
+ conditionals to use fwrappers for #+(version>= 6).
+
+ * swank-backend.lisp (make-stream-interactive): This backend
+ function is called with each stream that will be used for
+ user-interaction, i.e. the redirected stdio streams. Can be used
+ to setup special output-flushing or similar.
+
+ * swank.lisp (open-streams): Call make-stream-interactive on the
+ redirected io streams.
+
+ * swank-allegro.lisp (make-stream-interactive): Set
+ interactive-stream-p slot on the stream to make it auto-flush.
+ (*swank-thread*, *inherited-bindings*): New variables.
+ (spawn): Bind *swank-thread* to T.
+ (make-process/inherit): Fwrapper (advice) for
+ mp:make-process. When *swank-thread* is T then make the new thread
+ inherit "sliminess": debugger hook, I/O streams, and also
+ *swank-thread* so that its children will inherit too.
+
+2004-07-03 Luke Gorrie <luke(a)bluetail.com>
+
+ * hyperspec.el (common-lisp-hyperspec-section-4.0): Bugfix from
+ Lennart Staflin.
+
+ * slime.el (slime-repl-clear-output): Avoid clearing the previous
+ REPL expression too. Patch from Andras Simon.
+
+ * swank-backend.lisp (definterface): Don't use
+ NO-APPLICABLE-METHOD for default methods. Instead just define them
+ as regular methods with all argument types being
+ T. Defimplementation will then replace them by using the same
+ signature. N-A-M was a stupid idea!
+
+2004-07-02 Brian Downing <bdowning(a)lavos.net>
+
+ * slime.el (slime-reindent-defun): Added a check for (boundp
+ 'slime-repl-input-start-mark) before checking the variable, as
+ XEmacs leaves variables unbound when `make-variable-buffer-local'
+ is run, while GNU Emacs binds them to NIL.
+
+2004-07-02 Martin Simmons <martin(a)xanalys.com>
+
+ * swank-lispworks.lisp (dspec-stream-position,
+ make-dspec-location): Fix typo in features for LW 4.1 and 4.2.
+
+2004-07-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp (frame-actual-args): Bind
+ *break-on-signals* to nil and special case &rest, &optional, and
+ &key.
+
+2004-07-01 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-lookup-reference): Preserve case in SBCL node
+ names. Previously they were downcased, but the HTML manual's
+ filenames seem to have changed.
+
+ * NEWS: Added security note about the TCP server.
+ Added notes for ACL and ABCL.
+
+ * doc/slime.texi: General updatings for an alpha release.
+
+2004-06-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-display-compilation-output): New customizable
+ variable.
+
+ * swank.lisp: Minor cleanups.
+ (find-symbol-designator, find-symbol-or-lose)
+ (case-convert-input): Deleted. Replaced with calls to
+ parse-symbol{-or-lose}.
+
+ * swank-lispworks.lisp (describe-symbol-for-emacs): Include
+ information about setf-functions.
+ (emacs-connected): Add a default method to
+ env-internals:environment-display-debugger.
+
+2004-06-30 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-read-port-and-connect-to-running-swank)
+ (slime-connect, slime-open-stream-to-lisp): Replace "localhost"
+ with "127.0.0.1". This is believed to avoid unwanted DNS lookups
+ on certain operating systems. The lookups can become crippling if
+ the DNS server isn't available.
+ (line-beginning-position, line-end-position): Simple bugfix
+ suggested by Richard Klinda.
+
+ * swank-sbcl.lisp (preferred-communication-style): Choose
+ :fd-handler instead of :sigio when threads aren't available. A lot
+ of people seem to have had problems with :sigio on SBCL.
+
+2004-06-30 Luke Gorrie <luke(a)bluetail.com>
+
+ * NEWS: Wrote preliminary release notes for alpha-1.
+
+2004-06-29 Luke Gorrie <luke(a)bluetail.com>
+
+ * mkdist.sh: New shell script for creating a tarball for
+ distribution.
+
+2004-06-29 Bill Clementson <Bill_Clementson(a)peoplesoft.com>
+
+ * slime.el (slime-who-map): Add extra bindings for the XREF
+ commands as with the documentation commands. Now `C-c C-w C-c' is
+ `slime-who-calls' in addition to `C-c C-w c', etc.
+
+2004-06-29 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-prune-initial-frames): Tweaked regexp for
+ matching SWANK's own stack frames for effectiveness in SBCL.
+ (slime-keys): Shadow remaining inf-lisp keys (C-c C-a, C-c C-v)
+ with a null `slime-nop' command until we put them to a real use.
+
+ * swank.lisp (open-streams): Renamed the restart around reads from
+ the user-input stream from ABORT to ABORT-READ. Invoking this
+ restart seems kinda dangerous, so better for 'a' in SLDB not to do
+ so.
+
+2004-06-28 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU>
+
+ * swank.lisp (inspector-nth-part):
+ * slime.el (slime-inspector-copy-down, slime-inspector-mode-map):
+ Added copy-down command (M-RET) to easily move an object from the
+ inspector to the repl.
+
+2004-06-28 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-doc-map): New keymap for documentation
+ commands. These all use the `C-c C-d' prefix, followed by:
+ a - apropos
+ p - apropos-package
+ z - apropos-all
+ d - describe-symbol
+ f - describe-function
+ h - hyperspec lookup
+ ~ - hyperspec lookup of a format character
+ The final keystroke is bound both unmodified and with control, so
+ both `C-c C-d a' and `C-c C-d C-a' will make an apropos
+ search. The exception is hyperspec-lookup, because it's nice to
+ leave C-h unbound so that `C-c C-d C-h' will summarise the
+ documentation bindings.
+
+2004-06-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp (nth-frame): Skip frames where
+ frame-visible-p is false.
+
+ * slime.el (slime-buffer-package): Return the cached package if we
+ can't find something more sensible; this reverts a previous
+ change. The Lisp side will now fall back to an existing package
+ if the one supplied by Emacs doesn't exist. Using the cached
+ version is also necessary for some commands in the apropos buffer.
+ (sldb-insert-frame): Set the default-action property; pressing RET
+ on frame lines now shows/hides details.
+ (sldb-toggle-details): Preserve the current column.
+ (slime-inspector-buffer, slime-saved-window-config)
+ (slime-inspector-quit): Save and restore the window configuration.
+ (slime-highlight-suppressed-forms, slime-search-suppressed-forms):
+ Display expressions with reader conditionals (#+/#-) in
+ font-lock-comment-face if the test is false. Not implemented for
+ XEmacs.
+ (repl-return): New test.
+
+2004-06-28 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el: Events in the *slime-events* buffer are now exact
+ on-the-wire messages, without including e.g. Elisp continuation
+ functions. This is easier for debugging I think.
+
+ * swank-allegro.lisp (compute-backtrace): Only include frames
+ satisfying `debugger:frame-visible-p'. I did this as a lame
+ workaround for a problem where `output-frame' was segfaulting on
+ certain frames, and those frames happened not to be visible-p. I
+ don't know if it really fixes anything.
+
+ * hyperspec.el (common-lisp-hyperspec-format): This command now
+ works at the end of the buffer, fixed `char-after' usage as
+ suggested by Johan Bockg�rd.
+
+2004-06-28 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * hyperspec.el: add support for issue cross-reference lookups,
+ strongly inspired by hyperspec symbol lookup.
+ (common-lisp-hyperspec-issuex-table,
+ common-lisp-hyperspec-issuex-symbols): new variables
+ (common-lisp-issuex): new function
+
+ * slime.el (sldb-format-reference-node, sldb-lookup-reference):
+ (sldb-reference-properties): use new support for issue lookups
+ to support :ansi-cl :issue reference types.
+
+ * hyperspec.el: add support for glossary lookups.
+ (common-lisp-glossary-fun): new variable
+ (common-lisp-glossary-4.0, common-lisp-glossary-6.0): new functions
+
+ * slime.el (sldb-format-reference-node, sldb-lookup-reference):
+ (sldb-reference-properties): use new support for glossary lookupts
+ to support :ansi-cl :glossary reference types.
+
+2004-06-27 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * doc/slime.texi: Remove macros from chapter and section headings
+ to avoid texi2pdf breakage.
+
+ * swank-source-path-parser.lisp (cmucl-style-get-macro-character):
+ Add tests for #\space and #\\. Suggested by Christophe Rhodes.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp,
+ swank-cmucl.lisp, swank-backend.lisp, swank-allegro.lisp,
+ swank-abcl.lisp (thread-id, find-thread): New backend functions.
+
+ * swank.lisp (dispatch-event): Quitting from the debugger was
+ seriously broken. Fix it. Move generation of thread ids to the
+ backends.
+ (encode-message, send-to-socket-io): Use WITHOUT-INTERRUPTS in
+ send-to-socket-io. The multithreaded version of encode-message
+ doesn't need it.
+ (nth-thread): Renamed from lookup-thread-by-id.
+ (debug-nth-thread): Renamed from debug-thread-by-id:
+ (kill-nth-thread): Renamed from kill-thread-by-id.
+
+ * slime.el (sldb-get-buffer): Add support for sldb buffers for
+ multiple threads.
+
+2004-06-25 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU>
+
+ * swank-sbcl.lisp (call-with-syntax-hooks, with-debootstrapping):
+ Preserve compatability with fairly recent SBCLs by checking for
+ the presense of the debootstrapping facilities at macroexpansion
+ time.
+
+ * slime.el (sldb-insert-condition): Initialize sldb-default-action
+ so that pressing RET inspects the condition.
+
+2004-06-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-repl-insert-prompt): Set defun-prompt-regexp.
+ beginning-of-defun can be very slow in the repl buffer if the
+ defun-prompt-regexp is not set.
+ (sldb-insert-locals): Initialize sldb-default-action.
+ (sldb-var-number-at-point, sldb-inspect-var): New function.
+
+ * swank.lisp (inspect-frame-var): New function.
+
+ * swank-backend, swank-cmucl.lisp, swank-sbcl.lisp,
+ swank-allegro.lisp, swank-lispworks.lisp, swank-clisp.lisp
+ (frame-var-value): New backend function.
+
+2004-06-24 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * slime.el (sldb-format-reference-node): fix for when `what' is a
+ list.
+ (sldb-lookup-reference,sldb-reference-properties): support
+ :ansi-cl :section reference types.
+
+ * hyperspec.el (common-lisp-hyperspec-6.0): generalize to work
+ with section numbers lower than 10.
+
+2004-06-24 Brian Downing <bdowning(a)lavos.net>
+
+ * slime.el (slime-repl-send-input): Fixed a subtle difference in
+ sending input to the Lisp introduced in 1.316. The newline was
+ not getting sent, resulting in the Lisp constantly asking for more
+ read data. I believe the code has been adjusted to behave the
+ same as 1.315 with regard to sending newlines.
+ Also adjusted the `slime-repl-old-input' text property to end just
+ before the newline, not just after. This causes a gap between
+ inputs even if no Lisp output appeared in between, so that putting
+ point on an old line and hitting RET will only call up that line,
+ and hitting RET in the middle of the current line will send it and
+ not bring up a confusing combination of all previous input.
+ Many thanks to Loyd Fueston for pinpointing the date and exact
+ patch for when this problem was introduced.
+
+2004-06-23 Brian Downing <bdowning(a)lavos.net>
+
+ * slime.el: Re-added most of Luke's patches from yesterday. It
+ has the shortened names, uses markers instead of stored `(point)'
+ values, and `slime-fuzzy-complete-symbol' is an option for
+ `slime-complete-symbol-function'.
+ It still string compares the target buffer instead of using
+ `(buffer-modified-tick)'.
+ I left the `C-c M-i' keybinding in, as it allows use of the
+ regular completion as well. If there's an objection to this it
+ can be removed.
+ `window-configuration-change-hook' is used if the variable is
+ present, and ignored it not. This neatly sidesteps its absence in
+ XEmacs while not killing the functionality for GNU Emacs.
+
+ * doc/slime.texi: Added a command entry and short description for
+ `C-c M-I, slime-fuzzy-complete-symbol', and added its existence to
+ the `slime-complete-symbol-function' documentation.
+
+2004-06-22 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/slime.texi: Noted ABCL support.
+
+ * slime.el: Backed out all of my changes to fuzzy completion. I
+ was too hasty and didn't do good things. Now it's back in pristine
+ state from Brian's patch -- use `C-c M-i' to fuzzy-complete.
+
+ * doc/Makefile (contributors.texi): The contributors list in the
+ manual is now sorted by most number of ChangeLog entries. Patch
+ from Michael Weber.
+
+ * slime.el: Some minor hacking to fuzzy completion:
+ Use the shorter `slime-fuzzy-' symbol prefix.
+ Use markers instead of numbers to remember where the completion is
+ being done. This way they are self-updating.
+ Use `buffer-modified-tick' to detect modifications instead of text
+ comparison.
+ Always restore window configuration when a completion is
+ chosen. For this completion style I think this will work okay
+ [famous last words], and the existing code wasn't
+ XEmacs-compatible for want of window-configuration-change-hook.
+ Now there is no separate keybinding for fuzzy completion, but it's
+ included as a customize option for `slime-complete-symbol-function'
+
+2004-06-22 Brian Downing <bdowning(a)lavos.net>
+
+ * slime.el, swank.lisp: Added "fuzzy completion."
+
+2004-06-22 Matthew Danish <mdanish(a)andrew.cmu.edu>
+
+ * swank-backend.lisp (unbound-slot-filler): New structure for
+ representing an unbound slot in the inspector functions.
+
+ * swank.lisp, swank-allegro.lisp: Use it.
+
+2004-06-22 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-output-filter): Choose connection based on
+ process-buffer, not current buffer. This fixes a bug where output
+ from multiple Lisp sessions could get mixed up.
+ (slime-kill-all-buffers): Include all *inferior-lisp*[<n>] buffers.
+ Split the customize settings into more subgroups.
+
+ * swank.lisp (prefixed-var): Intern *REAL-STANDARD-INPUT* etc in
+ the SWANK package instead of the COMMON-LISP package.
+
+2004-06-21 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-loader.lisp (*lisp-name*): Add version number to
+ Lispwork's fasl directory. We should do this for ACL and OpenMCL
+ too, but for some reason my ACL 5.0 gets an error when trying to
+ create a directory with a version number in its name, and I don't
+ have OpenMCL to test with.
+
+ * swank-backend.lisp, swank.lisp (add-hook, run-hook): Moved the
+ hook mechanism and all hooks to swank.lisp (from
+ swank-backend.lisp). There is no compelling use for the hooks in
+ backends yet and I want to pass swank.lisp-internal data
+ structures in the existing hooks.
+ (notify-backend-of-connection): Call `emacs-connected' with the
+ user-io stream for its argument. Should fix previous breakage
+ where the connection structure was passed instead.
+ (*globally-redirect-io*): New configurable: when true the standard
+ streams are globally redirected to Emacs. That way even
+ e.g. SERVE-EVENT handlers will print to Emacs. Currently does not
+ handle standard input -- that is trickier since the Lisp's native
+ REPL can be trying to read from that.
+
+ * slime.el (slime-complete-maybe-restore-window-configuration):
+ Only restore the window configuration if the completions buffer is
+ currently visible in the window that we popped it up in.
+ (slime-complete-maybe-save-window-configuration): Don't save the
+ window configuration if the completions buffer is already visible.
+ (slime-repl-return): Make sure the newline goes at the end of the
+ input, not at point.
+ (slime-complete-restore-window-configuration): Wrap the
+ `set-window-configuration' call in (run-at-time 0 ..). XEmacs does
+ not allow us to set the window configuration from inside
+ pre-command-hook.
+
+2004-06-20 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-sbcl.lisp (emacs-connected): Set *invoke-debugger-hook* to
+ our debugger hook. Not optimal, but at least BREAK will then
+ invoke our debugger.
+ (*trap-load-time-warnings*): New variable. If it is true,
+ conditions, most notably redefinition warnings, signalled at load
+ time are not trapped.
+ (swank-compile-file, swank-compile-string): Use it.
+
+ * swank.lisp (guess-buffer-package): Don't signal a continuable
+ error if the package doesn't exists; that's too annoying.
+
+ * slime.el: Fix outline structure.
+ (slime-maybe-list-compiler-notes): Fix thinko.
+ (break): New test. Reorganize the test-suite a bit to support
+ "expected failures".
+ (slime-eval-feature-conditional, slime-to-feature-keyword): Add a
+ ?: to the symbol-name if needed.
+
+2004-06-20 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (changelog-date): Removed unneeded function.
+ (connection-info): No more version field in result.
+
+ * slime.el: Audited to remove namespace slipups. Tracking a really
+ horrible clashing-with-some-user-configuration bug and want to
+ eliminate potential symbol conflicts.
+ (sldb-get-buffer): Renamed from `get-sldb-buffer'.
+ (slime-emacs-20-p): Renamed from `emacs-20-p'.
+ (slime-defun-if-undefined): Renamed from `defun-if-undefined'.
+ (slime-isearch): Small bugfix that could cause M-. to go to the
+ wrong place in CMUCL.
+ (slime-changelog-date, slime-check-protocol-version): Removed
+ unneeded functions.
+
+ * swank-backend.lisp (add-hook, run-hook): Added an Emacs-like
+ hook mechanism. The hope is that this will make some sections of
+ the code more self-describing by showing where they hook in.
+ (*new-connection-hook*): Hook run when a new connection is
+ established. Initialized to '(swank-backend:emacs-connected).
+ (*pre-reply-hook*): Hook run before sending a reply to Emacs.
+
+ * swank.lisp: Added some comments and docstrings.
+ (package-external-symbols): Removed unused function.
+ (serve-connection): Call *new-connection-hook*.
+ (eval-for-emacs): Call *pre-reply-hook*.
+ (sync-features-to-emacs, sync-indentation-to-emacs): Added to
+ *pre-reply-hook*.
+ (cl-package, keyword-package): Now defconstant instead of
+ defvar. Removed the *'s accordingly.
+
+ * slime.el (slime-abort-connection): Renamed from
+ `slime-connection-abort'. The new name is easier to find with
+ completion.
+
+ * swank-sbcl.lisp: Change sb-posix:: to sb-posix:
+
+2004-06-19 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (known-to-emacs-p): Bugfix. Indentation-updates was
+ broken.
+
+2004-06-18 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-buffer-package): If DONT-CACHE is true and no
+ package name can be found, then default to "COMMON-LISP-USER."
+ Previously we just kept using the cached version, but that could
+ lead to error-after-error if it was incorrect.
+
+ * swank.lisp (throw-to-toplevel): If our top-level catcher isn't
+ on the stack (i.e. we're using the debugger from outside an RPC)
+ then ABORT instead. That makes 'q' DWIM in SLDB.
+
+2004-06-18 Matthew Danish <mdanish(a)andrew.cmu.edu>
+
+ * swank-allegro.lisp (frame-source-location-for-emacs):
+ Implemented.
+
+2004-06-18 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-repl-return): If the user presses return on old
+ REPL input then take it and insert it as the current input.
+ Signal an error if the point is not on any input.
+ (slime-preserve-zmacs-region): Function to ensure that the current
+ command doesn't deactivate zmacs-region (XEmacs only).
+ (slime-repl-bol, slime-repl-eol): Use it.
+ (slime-kill-all-buffers): Changed buffer-name regexps for XEmacs
+ compatibility. The ",quit" shortcut now works in XEmacs.
+ (slime-display-message): Fixed call to `slime-typeout-message'
+ to handle formatting characters. Avoids errors on certain messages.
+ (slime-list-compiler-notes): Save the window configuration
+ earlier. This fixes an error under XEmacs when dismissing the
+ notes buffer.
+ (slime-recenter-window): Avoid moving the point. This keeps the
+ point in the right place when showing debugger-frame locations in
+ Emacs 21.
+
+2004-06-17 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-loader.lisp (binary-pathname): Place fasl files under
+ ~/.slime/fasl/ instead of the SLIME installation directory. The
+ installation directory can now be read-only.
+ (binary-pathname, user-init-file): Removed Win32
+ conditionalization. The init file is now called ~/.swank.lisp
+ instead of ~/_swank.lsp.
+
+ * swank-lispworks.lisp (with-fairly-standard-io-syntax): New
+ macro. Like with-standard-io-syntax, but keeps the existing values
+ of *package* and *readtable*.
+ (dspec-stream-position): Use it.
+ (quit-lisp): Implemented.
+
+2004-06-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-set-default-directory): Don't call
+ slime-repl-update-banner in Emacs 20.
+ (slime-show-source-location, slime-recenter-window): Use
+ set-window-start instead of recenter; this avoids flickering.
+ (sldb-list-locals): Don't forget about slime-current-thread in the
+ temporary buffer. (Fixes bug reported by Mike Beedle.)
+ (sldb-step): Re-enabled. The CMUCL backend has rudimentary support
+ for stepping.
+
+ * swank.lisp (*readtable-alist*): Call backend function for
+ initialization.
+ (eval-for-emacs, guess-buffer-package): Signal a continuable error
+ if a package name was supplied but no such package exists. Not
+ sure if this is better than what we did before (i.e. silently use
+ the current package).
+
+ * swank-cmucl.lisp (default-directory): Add implementation.
+ (sldb-step): Uncomment it and remove references to
+ *swank-debugger-condition*.
+
+ * swank-backend.lisp (sldb-step, default-readtable-alist): New
+ backend functions.
+ (emacs-connected): Pass the redirected stream as argument, so that
+ the OpenMCL backend can add it to CCL::*AUTO-FLUSH-STREAMS*.
+
+ * swank-sbcl.lisp (default-readtable-alist): Implement it.
+
+ * swank-loader.lisp: Move readtable-alist initialization to
+ swank-sbcl.lisp.
+
+ * swank-allegro.lisp (default-directory, call-with-syntax-hooks):
+ Add implementations as workarounds for ACL5 bugs.
+
+2004-06-16 Lawrence Mitchell <wence(a)gmx.li>
+
+ * slime.el (slime-maybe-rearrange-inferior-lisp): Call
+ `generate-new-buffer-name' manually, rather than relying on the
+ UNIQUE argument to `rename-buffer' to do so.
+
+2004-06-16 Frederic Brunel <frederic.brunel(a)in-fusio.com>
+
+ * slime.el (slime-startup-animation): Use defcustom to declare the
+ variable.
+ (slime-enable-startup-animation-p): Deleted.
+
+2004-06-16 Robert Lehr <bozzio(a)the-lehrs.com>
+
+ * slime.el (slime-backend): This variable can now be set to an
+ absolute filename.
+
+2004-06-15 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-compile-file): Just prompt for saving the
+ current file instead of calling `save-some-buffers'. Based on a
+ patch from Brian Downing.
+
+2004-06-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * wank-allegro.lisp (format-sldb-condition, condition-references):
+ Add workarounds for buggy no-applicable-method.
+
+ * swank.lisp (parse-symbol, parse-package): Handle reader errors.
+
+ * swank-openmcl.lisp (send, receive): Ensure that messages are
+ never nil.
+
+2004-06-10 Christophe Rhodes <csr21(a)cam.ac.uk>
+
+ * swank-sbcl.lisp (call-with-syntax-hooks): Add hooks to fix
+ "SB!"-style package names.
+ (shebang-readtable): Return a readtable with readermacros needed
+ to parse SBCL sources.
+
+ * swank.lisp (with-buffer-syntax): New macro. This should be used
+ for code which needs to READ code from Emacs buffers. *package*
+ and *readtable* are bound suitable values.
+ (to-string, format-values-for-echo-area, interactive-eval)
+ (eval-region, interactive-eval-region, re-evaluate-defvar)
+ (swank-pprint, pprint-eval, listener-eval)
+ (compile-string-for-emacs, disassemble-symbol, describe-to-string)
+ (describe-symbol, describe-function)
+ (describe-definition-for-emacs)
+ (documentation-symbol, init-inspector, inspect-nth-part)
+ (inspector-pop, inspector-next, describe-inspectee)
+ (inspect-current-condition): Use it.
+
+2004-06-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-loader.lisp: Initialize swank::*readtable-alist* for SBCL.
+
+ * swank-backend.lisp (default-directory, call-with-syntax-hooks):
+ New functions.
+
+ * swank.lisp (*readtable-alist*): New configurable. The keys are
+ package name and the values readtables. The readtable will be
+ used to READ code originating from Emacs buffers in the associated
+ slime-buffer-package.
+ (drop-thread): Simplified.
+ (*buffer-readtable*): New variable.
+ (parse-package): New function.
+ (parse-string): Renamed from symbol-from-string. Make it case
+ insensitive.
+ (eval-for-emacs): Initialize the *buffer-readtable*.
+ (symbol-indentation): Don't consider symbols in the CL package.
+ Emacs already knows how to indent them.
+ (compile-file-if-needed): Used for REPL shortcut
+ 'compile-and-load'.
+
+ * slime.el (pwd): Re-add REPL shortcut.
+ (slime-repl-push-directory, slime-repl-compile-and-load): Simplified.
+
+2004-06-10 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-step): Command is disabled because the function
+ `swank:sldb-step' that it calls doesn't exist. I don't see any
+ stepping code in our backends.
+
+2004-06-09 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-goto-location-position) [:function-name]: The
+ function name can also occur after a ?(, not only after
+ whitespace.
+
+ * (slime-init-output-buffer): Initialize the package stack.
+ Reported by Rui Patroc�nio.
+
+ * (slime-completions): Make it consistent with
+ slime-simple-completions. The second argument was never supplied.
+ Reported by Rui Patroc�nio.
+
+2004-06-09 Eric Blood <eblood(a)winkywooster.org>
+
+ * slime.el (slime-indent-and-complete-symbol): Renamed from
+ slime-repl-indent-and-complete-symbol.
+
+ (slime-typeout-frame-properties): Add more default options for the
+ typeout frame--specifically it now has a default width, and moves
+ the typeout frame to the upper right.
+
+2004-06-09 Andras Simon <andras(a)renyi.hu>
+
+ * swank-abcl.lisp: New backend for Armed Bear Common Lisp.
+
+ * swank-loader.lisp: Add ABCL support.
+
+2004-06-09 Martin Simmons <martin(a)xanalys.com>
+
+ * swank-lispworks.lisp (dspec-stream-position): New function to
+ make source location work for anything complicated e.g. methods.
+ (with-swank-compilation-unit): Refactoring.
+ (who-macroexpands): Implemented.
+ (list-callers): Implemented.
+
+ * swank-backend.lisp (network-error): Inherit from simple-error to
+ get correct initargs.
+
+2004-06-09 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-insert-references): Added support for hyperlinked
+ references as part of conditions being debugged. This is a new
+ feature in SBCL to reference appropriate sections of their manual
+ or CLHS from condition objects. The references are clickable.
+
+ * swank-backend.lisp (format-sldb-condition): New backend function
+ to format conditions for SLDB.
+ (condition-references): New function to return a list of
+ documentation references associated with a condition.
+
+ * swank.lisp (debugger-condition-for-emacs): Call the above
+ backend functions to add a `references' list for Emacs.
+
+ * swank-sbcl.lisp (format-sldb-condition, condition-references):
+ Implemented. Requires a recent (latest?) SBCL release.
+
+2004-06-08 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-cmucl.lisp (close-socket): Remove any SERVE-EVENT handlers
+ for the socket's file descriptor.
+
+ * swank-sbcl.lisp (close-socket): Same fix.
+
+2004-06-07 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-cmucl.lisp: Minor refactorings.
+
+2004-06-07 Edi Weitz <edi(a)agharta.de>
+
+ * swank-allegro.lisp (call-with-compilation-hooks): Implemented.
+ Wrap IMPORT call in EVAL-WHEN.
+
+ * swank.lisp, swank-backend.lisp: Wrap EXPORT calls in
+ EVAL-WHEN. Fixes many warnings in ACL.
+
+2004-05-25 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-kill-without-query-p): Default to T.
+ (sldb-highlight): Variable to control face-based highlighting of
+ SLDB locations. (In Emacs21 the point is visible even in unselected
+ windows, which is sufficient for me.)
+ (sldb-show-location-recenter-arg): Argument to `recenter' when
+ showing SLDB locations. Default to nil, i.e. location appears in
+ the middle of the window.
+
+2004-05-24 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-input-complete-p): Return nil for unbalanced
+ sexps starting with quote ?', backquote ?`, or hash ?#. C-j can
+ be used for more complicated cases.
+
+2004-05-22 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-repl-sayoonara): Added "quit" as an alias for
+ sayoonara.
+
+2004-05-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (arglist): Catch (reader) errors in
+ READ-ARGLIST.
+
+ * swank-allegro.lisp (fspec-primary-name): New function.
+ (find-fspec-location): Use it, if the start position cannot be
+ found.
+
+ * slime.el (slime-pprint-event): New function.
+ (slime-log-event): Use it.
+ (slime-reindent-defun): Indent the form after point, if point is
+ in the first column an immediately before a #\(.
+
+2004-05-21 Bill Clementson <Bill_Clementson(a)peoplesoft.com>
+
+ * slime.el (slime-switch-to-output-buffer): Use "P" as interactive
+ spec.
+
+2004-05-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-switch-to-output-buffer): Override the
+ prefix-arg if we are called non-interactively.
+ (slime-repl-current-input): Don't add newlines.
+ (slime-repl-return): Send input if we are in read-mode also if it
+ isn't a complete expression.
+ (repl-read-lines): New test case.
+ (slime-enable-startup-animation-p): New configurable.
+ (slime-repl-update-banner): Use it.
+ (slime-hide-inferior-lisp-buffer): New function. Reuse the
+ *inferior-lisp* buffer window for the SLIME REPL.
+
+ * swank-allegro.lisp (find-fspec-location): Better handling of
+ methods. From Bill Clementson.
+
+2004-05-17 Luke Gorrie <luke(a)bluetail.com>
+
+ * xref.lisp, swank-clisp.lisp: Renamed XREF package to PXREF (P
+ for portable). This makes it possible to load the package in
+ e.g. CMUCL, which is nice because it's a good package.
+
+ * swank-cmucl.lisp: Some refactoring and high-level
+ commenting. Mostly just trying to organise things into fairly
+ self-contained sections (my new hobby, sad I know!)
+
+ * slime.el: Added `C-c C-e' as an alternative binding for
+ `slime-interactive-eval' (usually `C-c :'). This seems slightly
+ more convenient, and has the added bonus of clobbering an unwanted
+ `inf-lisp' binding.
+
+2004-05-14 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-with-output-to-temp-buffer): Now takes a
+ package arg specifying what slime-buffer-package should be in the
+ generated buffer.
+ (slime-show-description): actually pass the package arg.
+ (slime-show-apropos): pass the package arg to
+ slime-with-output-to-temp-buffer.
+ (slime-list-repl-shortcuts): pass a package arg.
+
+2004-05-12 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-openmcl.lisp: Fixes to support openmcl 0.14.2 changes in
+ backtrace protocol, from Gary Byers.
+ - Replace string "tcr" to "context".
+ - Change the call to %current-tcr in map-backtrace to get-backtrace-context,
+ defined so as to be back compatible with 0.14.1.
+ - Change the call to %catch-top to explicitly use %current-tcr
+ instead of the passed in tcr-which-is-now-called-context.
+
+ Users of map-backtrace (outside of slime code) note: The tcr position in the
+ function call is now occupied by the backtrace "context" which is always nil.
+ If you really need the tcr then you need to call %current-tcr yourself now.
+
+ Gary comments: The part that's a little hard to document about
+ the new "context" stuff - used to walk the stacks of thread A from
+ thread B - is that thread B has to be aware of when a context
+ becomes invalid (a context describing part of thread A's stack is
+ valid while thread A's sitting in a break loop and becomes invalid
+ as soon as it exits that break loop.) A thread sort of announces
+ when a context becomes valid and when it becomes invalid; whether
+ and how SWANK could hook into that isn't yet clear.
+
+ * swank-openmcl.lisp: Minor changes to backtrace display: Anonymous
+ functions names in function position surrounded by #<>. Use prin1 instead of
+ princ to print function arguments (so strings have "s around them).
+ prefix symbol and list arguments by "'" to make them more look like a
+ valid function call. Let me know if you don't like this...
+
+2004-05-12 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el: Fixes for outline-mode in *slime-events* from Edi
+ Weitz.
+
+2004-05-11 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-events-buffer): Disable outline-mode by default.
+ (slime-inhibit-ouline-mode-in-events-buffer): New variable.
+ (slime-expected-failures): Reduce the number for SBCL.
+
+ * swank-sbcl.lisp (resolve-note-location): Resolve the location if
+ we are called by swank-compile-string. The pathname argument is
+ never :stream in SBCL, so the method written for CMUCL was never
+ called.
+
+2004-05-10 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (from-string): Bind *READ-SUPPRESS* to NIL.
+ (swank-compiler): Bind a restart to abort compilation but still
+ report the compiler messages already trapped.
+ (string-to-package-designator): Function that uses READ to
+ case-convert package names.
+ (apropos-list-for-emacs): Use it.
+
+ * slime.el (slime-eval-with-transcript): Don't print the "=>"
+ prefix in messages showing evaluation results. It mucks up
+ alignment in multi-line messages.
+ (sldb-eval-in-frame): Don't print "==>" prefix on evaluation
+ results, for the same reason.
+ (slime-show-source-location): Move the point to the source
+ location in addition to highlighting the matching parens.
+
+2004-05-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (find-definitions): Add support for variables
+ and constants.
+
+2004-05-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-clisp.lisp (compiler-note-location): Use make-location to
+ instead of `(:location ...). This initializes the new hint slot
+ automatically.
+
+2004-05-07 Barry Fishman <barry_fishman(a)att.net>
+
+ * swank.lisp (prin1-to-string-for-emacs, arglist-to-string): CVS
+ CLISP prints NIL as |COMMON-LISP|::|NIL| if *print-readably* is
+ true. Set *print-readably* to nil for a more Emacs friendly
+ printer syntax.
+
+2004-05-06 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-maybe-list-compiler-notes): Display the notes
+ listing after C-c C-c only if there are no annotations in the
+ buffer. CMUCL creates usually one warning with an error location
+ and an almost redundant warning without at the end of the
+ compilation unit. Don't display the listing in this common case.
+
+ (slime-reindent-defun): Pass nil as the third arument to
+ indent-region.
+
+2004-05-06 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-repl-sayoonara): Don't attempt to quit the lisp
+ if we're not connected.
+
+ * swank-openmcl.lisp (*buffer-offset*, *buffer-name*): Supply
+ default values. This avoids unbound value errors when compiling an
+ asdf system signals errors.
+
+2004-05-04 Alan Shutko <ats(a)acm.org>
+
+ * slime.el (slime-compiler-notes-show-details/mouse): New command.
+ (slime-compiler-notes-mode-map): Use it.
+
+2004-05-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (arglist): Handle byte-code functions better.
+ We don't know much about the actual argument list, only the number
+ of arguments. Return at least something mildly interesting like
+ (arg0 arg1 &optional arg2 ...)
+ (function-location): Special-case byte-code functions.
+
+ * swank-backend.lisp (with-struct): New macro.
+
+2004-05-04 Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU>
+
+ * slime.el (slime-reindent-defun): New command on C-M-q. Reindent
+ the current Lisp defun after trying to close any unmatched
+ parenthesis. If used within a comment it just calls fill-paragraph.
+
+2004-05-04 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-goto-location-position): Regexp fix.
+ (slime-reindent-defun): New command on M-q. Reindent the current
+ Lisp defun after trying to close any unmatched parenthesis.
+
+ * swank.lisp: Remove (declaim (optimize ...)). The side-effect
+ this has on people's environment seems harmful (I saw someone
+ having trouble on the OpenMCL list).
+
+ * swank-cmucl.lisp (source-location-from-code-location): Fixed a
+ bug where the source-file-cache was not really used.
+ Now always report the location based on source file (cached or
+ not) even if modified -- not falling back on regexps, which was
+ probably a misfeature.
+
+ * slime.el: Remove `slime-cleanup-definition-refs'.
+
+2004-05-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-start-and-load): New command. Suggested by
+ Lars Magne Ingebrigtsen.
+
+2004-05-02 Lars Magne Ingebrigtsen <larsi(a)netfonds.no>
+
+ * slime.el (slime-kill-without-query-p): New variable.
+ (slime-net-connect): Use it.
+ (slime-open-stream-to-lisp): Ditto.
+ (slime-maybe-start-lisp): Ditto.
+
+2004-05-02 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-goto-source-location): Added support for the
+ :snippet "hint" in a location specifier. If Lisp sends the
+ (initial) source text for the definition then Emacs isearches for
+ it in both directions from the given character position. This
+ makes M-. robust when the Emacs buffer has been edited. Requires
+ backends to provide this snippet information.
+ (slime-goto-location-position): Tightened up the regular
+ expressions for :function-name style location search.
+ (slime-cleanup-definition-refs): New function to do a little
+ post-processing on definition references from Lisp. Mostly this is
+ a hack: if POSITION is NIL then we fill it in with the function
+ name, ready for regexp search. I was in a hurry and it was easier
+ to do here, and it doesn't seem entirely unreasonable.
+
+ * swank-backend.lisp (:location): Added a 'hints' property list
+ to the location structure. This is for extra information that
+ compliments the buffer/position.
+
+ * swank-cmucl.lisp (code-location-stream-position): Position the
+ argument stream at the definition before returning.
+ (source-location-from-code-location): Include the :snippet hint
+ for Emacs (see above). The snippet will only be accurate provided
+ that the source file on disk has not been modified.
+ (*source-file-cache*) The contents of all source files consulted
+ for M-. are now cached if they match the version of the running
+ code. This is so that we can accurately lookup source locations
+ even when the file is modified, provided we manage to get the
+ right version (by file timestamp) at least once.
+ (source-location-from-code-location): If the right source version
+ is not available on disk or in our cache then let Emacs fall back
+ on a regular expression search.
+
+2004-05-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp (find-top-frame): New function used to hide
+ debugger-internal frames.
+ (call-with-debugging-environment): Use it.
+
+2004-05-01 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-abort): Print a message if the Emacs RPC
+ returns. It shouldn't, if ABORT manages to unwind the stack, but
+ it currently does in OpenMCL due to some bug.
+ (slime-edit-definition-fallback-function): Name of a function to
+ try if the builtin edit-definition finding fails. You can set
+ this to `find-tag' to fall back on TAGS.
+
+ * swank.lisp (list-all-systems-in-central-registry): Use explicit
+ :wild in pathname for matching (needed in at least SBCL).
+
+ * swank-openmcl.lisp: Removed obsolete `swank-compile-system'.
+
+ * swank-sbcl.lisp: Removed obsolete `swank-compile-system'.
+ Removed some stale comments about supported features.
+
+2004-04-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-repl-update-banner): Don't print the working
+ directory. It rarely fits in a line and was only Emacs'
+ default-directory. M-x pwd is convenient enough.
+
+ * swank.lisp (symbol-indentation): Don't infer indentation for
+ symbols starting with 'def' or 'with-'. It was wrong most of the
+ time and Emacs' defaults are better.
+
+ * swank-lispworks.lisp (emacs-connected): Add methods to
+ stream-soft-force-output for socket-streams and
+ slime-output-streams. This flushes those streams automatically
+ (i assume it gets called when Lisp is idle).
+
+2004-04-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-repl-mode): Set slime-current-thread to
+ :repl-thread.
+
+ * swank.lisp (thread-for-evaluation, dispatch-event): Accept
+ :repl-thread as thread specifier and dispatch evaluation and
+ interrupt request properly.
+ (repl-thread-eval, repl-eval): Deleted. We do the special casing in
+ thread-for-evaluation.
+
+2004-04-29 Lars Magne Ingebrigtsen <larsi(a)netfonds.no>
+
+ * slime.el (slime-event-buffer-name): New variable.
+ (slime-events-buffer): Use it.
+ (slime-space-information-p): Ditto.
+ (slime-space): Use it.
+ (slime-reply-update-banner-p): Ditto.
+ (slime-repl-update-banner): Use it.
+
+2004-04-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-loader.lisp (*lisp-name*): Add versioning support for
+ CLISP.
+
+ * swank-clisp.lisp (arglist): Trap exceptions and return
+ :not-available in that case.
+
+ * swank.lisp (arglist-for-insertion): Don't use ~< ..~:@>.
+ CLISP's pretty printer can't handle it.
+
+2004-04-28 Luke Gorrie <luke(a)bluetail.com>
+
+ * NEWS: Created a NEWS file for recording changes that we want
+ users to read about.
+
+ * slime.el (slime-log-event): Use outline-minor-mode in
+ *slime-events* instead of hideshow-mode. It's more
+ reliable. (Patch from Lawrence Mitchell.)
+
+2004-04-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-net-connect): Bind inhibit-quit to nil, so that
+ we have a chance to interrupt Emacs if open-network-stream blocks.
+ (slime-complete-maybe-restore-window-configuration): Keep trying
+ after slime-repl-indent-and-complete-symbol.
+ (slime-space): Don't close the completion buffer. We don't know
+ the window-config before the completion, so leave the buffer open.
+
+ * swank.lisp (create-server): New keyword based variant to start
+ the server in background.
+ (setup-server): Add support to keep the socket open for
+ single-threaded Lisps.
+
+2004-04-27 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/slime.texi (Other configurables): Updated instructions on
+ globally installing SLDB on *debugger-hook*.
+
+ * slime.el (slime-log-event): Better bug-avoidance with
+ hs-minor-mode. Hopefully XEmacs users can rest safely now.
+ (slime-prin1-to-string): Bind `print-escape-newlines' to nil.
+ (slime-set-connection-info): Commented out call to
+ `slime-check-protocol-version'. Let's see how we do without it.
+ (slime-oneway-eval): Removed unused function.
+
+ * swank.lisp (oneway-eval-string): Removed unused function.
+
+2004-04-26 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp: Move definition of `with-io-redirection' above
+ `with-connection' to avoid a CLISP error. This is really weird.
+ (interactive-eval): Bind *package* to *buffer-package*, so that
+ `C-x C-e' and related commands evaluate in the expected package.
+
+ * slime.el (sldb-insert-frames): Handle empty backtrace (I got one
+ in CLISP).
+
+ * swank-allegro.lisp (arglist): Return :not-available if arglist
+ lookup fails with an error.
+
+ * slime.el: Moved snippets of Common Lisp code into swank.lisp
+ from the thread control panel. (Remember, no CL code in slime.el!)
+
+ * swank-loader.lisp (*lisp-name*): Include a short version number
+ in the Lisp name to separate FASL files for different
+ versions. Only implemented for CMUCL and SBCL sofar.
+
+ * swank.lisp (ed-in-emacs): Avoid mutating the argument.
+ (spawn-repl-thread): Add a new thread for evaluating REPL
+ expressions. This same thread is used for all REPL
+ evaluation. This fixes some issues with variables like * and **
+ in at least SBCL.
+
+ * nregex.lisp: Typo fix (thanks Barry Fishman).
+
+ * slime.el (slime-events-buffer): Don't use hideshow-mode in
+ XEmacs for the *slime-events* buffer. It causes obscure problems
+ for some users. Still used in GNU Emacs.
+
+2004-04-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-backend.lisp (arglist): Return a list or :not-available.
+ Don't return strings or raise exceptions.
+
+ * swank.lisp (arglist-for-echo-area): Simplified and adapted for
+ the new semantic of ARGLIST.
+ (arglist-for-insertion): Now a separate function.
+ (read-arglist): Deleted. No longer needed.
+
+ * swank-cmucl.lisp, swank-lispworks.lisp (arglist): Return
+ :not-available if the arglist cannot be determined.
+
+ * slime.el (slime-set-connection-info): Hide the *inferior-lisp*
+ buffer here, so that we have all the buffer rearrangement in one
+ place.
+ (slime-insert-arglist): Use swank:arglist-for-insertion.
+
+2004-04-24 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-init-connection-state): Use an asynchronous RPC
+ instead of slime-eval to reduce the amount of work we do in the
+ timer function. We can remove the workaround for the timer
+ problem.
+
+2004-04-23 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el: Updated top comments.
+ Make SLIME faces inherit from their font-lock cousins properly.
+ (slime-connect): Bind `slime-dispatching-connection' to avoid
+ being confused by old buffer-local variables when initializing
+ the connection. This fixes a bug where doing `M-x slime' from the
+ REPL could give a "Not connected" error.
+
+2004-04-22 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-read-system-name): Perform completion on all
+ systems in the central registry.
+
+ * swank.lisp (list-all-systems-in-central-registry): New function.
+
+2004-04-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-repl-update-banner): Add workaround to force the
+ proper behavior of the the first command in the REPL buffer.
+ (slime-repl-shortcut-history): Define the variable to make XEmacs
+ happy.
+
+2004-04-22 Tiago Maduro-Dias <tcmd(a)rnl.ist.utl.pt>
+
+ * slime.el (slime-space): Cleanup.
+ (slime-complete-restore-window-configuration): Use
+ slime-close-buffer instead of bury-buffer.
+
+2004-04-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Suppress byte-compiler warnings by binding
+ byte-compiler-warnings to nil.
+ (slime-repl-shortcut): Use a structure instead of a list for the
+ short cut info. Update the users accordingly.
+
+ * swank-cmucl.lisp (arglist): Return a list instead of the string.
+
+2004-04-21 Edi Weitz <edi(a)agharta.de>
+
+ * slime.el (slime-apropos): Add support for regexp-based apropos.
+ We use nregex, so the regexp syntax is different from Emacs'
+ regexps and bit restricted (alternation '|' and optional groups
+ '(xy)?' are not implemented).
+ (slime-insert-arglist): New command - stolen from ILISP. I always
+ thought this was quite useful.
+ (slime-oos): Fix typo.
+
+ * swank.lisp (apropos-symbols): Use regexp and support
+ case-sensitive matching.
+ (arglist-for-echo-area): New argument to control if the operator
+ name should be included.
+
+ * nregex.lisp: New file.
+
+ * swank-loader.lisp (*sysdep-pathnames*): Load it.
+
+2004-04-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * doc/slime.texi (Compilation): slime-remove-notes is bound to C-c
+ M-c not M-c. Noted by Edi Weitz.
+
+2004-04-21 Edi Weitz <edi(a)agharta.de>
+
+ * swank.lisp (list-all-package-names): Optionally include
+ nicknames in the result.
+
+ * slime.el (slime-read-package-name): Include nicknames in the
+ completions set.
+ (slime-repl-mode-map): Bind C-c : to slime-interactive-eval just
+ like in most other SLIME buffers.
+ (read-directory-name): Compatibilty defun.
+
+2004-04-20 Tiago Maduro-Dias <tcmd(a)rnl.ist.utl.pt>
+
+ * slime.el (slime-close-buffer): New utility function.
+ (slime-space): Use it to kill superfluous *Completions* buffers.
+
+2004-04-17 Raymond Toy <rtoy(a)earthlink.net>
+
+ * swank-cmucl.lisp (source-location-tlf-number)
+ (source-location-form-number): New functions to extract the
+ encoded form-numbers from source locations.
+ (resolve-stream-source-location, resolve-file-source-location):
+ Use them.
+
+2004-04-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-merge-notes): Use mapconcat instead of
+ (concat (slime-intersperse (mapcar ....)))
+ (slime-intersperse): Handle empty lists.
+
+2004-04-16 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/Makefile: Added 'install' and 'uninstall' targets for the
+ Info manual. It may be necessary to tweak `infodir' in the
+ Makefile to suit the local system before installing. (Patch from
+ from Richard M Kreuter.)
+
+ * doc/slime.texi (Top): The Top node is now smaller, with details
+ moved into Introduction. This makes the Info front page easier to
+ navigate. (Patch from Richard M Kreuter.)
+
+2004-04-15 Ivan Boldyrev <email@secret-by-request>
+
+ * slime.el (slime-handle-repl-shortcut): Call `completing-read'
+ with an alist as expected, using `slime-bogus-completion-alist'.
+
+2004-04-14 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/slime.texi (Shortcuts): Described REPL shortcuts.
+
+ * slime.el (slime-oos): Generic ASDF interface.
+ (force-compile-system, compile-system, load-system,
+ force-load-system): New REPL commands.
+
+ * swank-backend.lisp (operate-on-system): More generic interface
+ to ASDF.
+
+ * swank.lisp (operate-on-system-for-emacs): More generic
+ interface to ASDF.
+
+ * slime.el (slime-repl-mode-map): Portability fix for definition
+ of the REPL command character.
+ (slime-maybe-rearrange-inferior-lisp): Bugfix for running
+ multiple inferior lisps.
+
+2004-04-13 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-handle-repl-shortcut,
+ slime-list-all-repl-shortcuts, slime-lookup-shortcut,
+ defslime-repl-shortcut): Refactor repl shortcut code to provide a
+ more leggible help.
+
+2004-04-09 Lawrence Mitchell <wence(a)gmx.li>
+
+ * slime.el (slime-same-line-p): Use `line-end-position', rather
+ than searching for a newline manually.
+ (slime-repl-defparameter): Use VALUE, not VALUE-FORM.
+
+2004-04-08 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-repl-package-stack): New buffer local variable.
+ (slime-repl-directory-stack): New buffer local variable.
+ (slime-repl-command-input-complete-p): Remove.
+ (slime-repl-update-banner): New function.
+ (slime-init-output-buffer): Use slime-repl-update-banner.
+ (slime-repl-shortcut-dispatch-char): New variable.
+ (slime-repl-return): Don't check for repl commands anymore.
+ (slime-repl-send-repl-command): Remove.
+ (slime-repl-mode-map): Bind slime-repl-shortcut-dispatch-char to
+ slime-handle-repl-shortcut.
+ (slime-set-default-directory): Use read-directory-name, call
+ slime-repl-update-banner.
+ (slime-repl-shortcut-table): New global variable.
+ (slime-handle-repl-shortcut): New function.
+ (defslime-repl-shortcut): New macro for defining repl shortcuts.
+ (slime-repl-shortcut-help, "change-directory",
+ slime-repl-push-directory, slime-repl-pop-directory,
+ "change-package", slime-repl-push-package, slime-repl-pop-package,
+ slime-repl-resend, slime-repl-sayoonara, slime-repl-defparameter,
+ slime-repl-compile-and-load): New repl shortcuts.
+ (slime-kill-all-buffers): Kill sldb buffers as well.
+
+ * swank.lisp: Remove the repl related functions.
+ (requires-compile-p): New function.
+
+2004-04-07 Lawrence Mitchell <wence(a)gmx.li>
+
+ * slime.el (slime-repl-prompt-face): New face.
+ (slime-repl-insert-prompt): Use it.
+ (slime-with-chosen-connection, with-struct): Docstring
+ fix for function's arglist display.
+ (when-let, slime-with-chosen-connection, with-struct): Docstring
+ fix for function's arglist display.
+ (slime-read-package-name): Use `slime-bogus-completion-alist' to
+ construct completion table.
+ (slime-maybe-rearrange-inferior-lisp): Use `rename-buffer's
+ optional argument to rename uniquely.
+ (slime-check-connected): Display keybinding for `slime' via
+ `substitute-command-keys'.
+ (slime-repl-send-repl-command): Use whitespace character class in
+ regexp.
+ (slime-autodoc-stop-timer): New function.
+ (slime-autodoc-mode): Add `interactive' spec to specify optional
+ arg. This allows prefix toggling of mode (behaves more like
+ most Emacs modes now). Stop timer if switching mode off with
+ `slime-autodoc-stop-timer'.
+ (slime-autodoc-start-timer, slime-complete-symbol)
+ (slime-complete-saved-window-configuration)
+ (slime-insert-balanced-comments): Docstring fix.
+ (slime-ed): Call `slime-from-lisp-filename' on filename for list
+ case of argument.
+ (slime-insert-transcript-delimiter, slime-thread-insert): Use
+ ?\040 to indicate SPC.
+ (line-beginning-position): `forward-line' always puts us in
+ column 0.
+ (line-end-position): Define if not fboundp (for older XEmacs).
+
+2004-04-07 Peter Seibel <peter(a)javamonkey.com>
+
+ * swank-allegro.lisp (set-default-directory): Allegro specific
+ version that also uses excl:chdir.
+
+ * swank.lisp (swank-pprint): Add swank versions of two missing
+ pretty-printer control variables.
+
+2004-04-07 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (completion-set): Also complete package
+ names. (Patch from Sean O'Rourke.)
+ (find-matching-packages): Add a ":" to the end of package names
+ in completion.
+
+2004-04-06 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-bytecode-stale-p): Automatically check if
+ slime.elc is older than slime.el and try to help the user out if
+ so.
+
+2004-04-06 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-repl-command-input-complete-p): New function.
+ (slime-repl-send-string): New optional arg specifying what string
+ to put on slime-repl-input-history, usefull when this string
+ differs from what we actually want to eval.
+ (slime-repl-return): Check for repl commands and pass then to
+ slime-repl-send-repl-command.
+ (slime-repl-send-repl-command): New function.
+ (slime-kill-all-buffers): New function.
+
+ * swank.lisp: Define the various repl command handlers: sayoonara,
+ cd, pwd, pack and cload.
+
+ * swank-backend.lisp (quit-lisp): Define as part of the backend
+ interface and export.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp, swank-cmucl.lisp,
+ swank-clisp.lisp, swank-allegro.lisp (quit-lisp): implement.
+
+2004-04-06 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (macro-indentation): Check that the arglist is
+ well-formed. This works around a problem with ACL returning
+ arglists that aren't real lambda-lists.
+
+2004-04-05 Lawrence Mitchell <wence(a)gmx.li>
+
+ * swank.lisp (*swank-pprint-circle*, *swank-pprint-escape*)
+ (*swank-pprint-level*, *swank-pprint-length*): Fix typo in
+ docstring.
+
+ * slime.el (slime-arglist): Don't `message' arglist directly, in
+ case it contains %-signs.
+ (slime-repl-output-face): Fix quoting.
+ (slime-symbol-at-point): Call `slime-symbol-name-at-point',
+ rather than ourselves.
+ (slime-check-protocol-version): Docstring fix.
+
+2004-04-05 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/slime.texi (Semantic indentation): Documented new
+ automatically-learn-how-to-indent-macros feature.
+ Added auto version control header in subtitle.
+
+ * slime.el (slime-close-parens-at-point): New command bound to
+ C-a C-a. Inserts close-parenthesis characters at point until the
+ top-level form becomes well formed. Could perhaps be made fancier.
+ (slime-update-indentation): New command to update indentation
+ information (`common-lisp-indent-function' properties) based on
+ macro information extracted from Lisp. This happens
+ automatically, the command is just to force a full rescan.
+
+ * swank.lisp (connection): Added slots to track indentation caching.
+ (*connections*): List of all open connections.
+ (default-connection): Function to get a "default"
+ connection. This is intended to support globally using the
+ debugger hook outside the context of a SLIME request, which is
+ broken at present.
+ (with-connection): Don't setup a restart: that must be done
+ separately.
+ (sync-state-to-emacs): Call `update-connection-indentation'.
+ (update-connection-indentation): Automatically discover how to
+ indent macros and tell Emacs.
+
+ * swank-backend.lisp (arglist): Specify that strings returned
+ from ARGLIST should be READable.
+
+2004-04-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-maybe-list-compiler-notes): Display the notes
+ for C-c C-c, when there are notes without a good source-location.
+
+2004-04-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-sbcl.lisp: Remove the non-working workarounds for
+ non-existent fcntl. Reported by Brian Mastenbrook.
+ (preferred-communication-style): Use multithreading if futexes are
+ available, sigio if fcntl is present, and fd-handlers otherwise.
+ (resolve-note-location): Don't try to construct a source-location
+ if there's no context. Notes without location will be displayed
+ in the note-listing buffer.
+
+2004-04-01 Bill Clementson <Bill_Clementson(a)peoplesoft.com>
+
+ * swank-allegro.lisp (send): Fix misplaced parens.
+
+2004-03-31 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (debug-function-arglist): Return symbols if
+ possible.
+ (class-location): Support for experimental source-location
+ recording.
+
+2004-03-30 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-repl-result-face): New face.
+ (slime-inspector-mode-map): Add a binding for M-.
+ (compile-defun): Add test case for escaped double quotes inside a
+ string.
+
+ * swank.lisp (ed-in-emacs): New allowed form for argument.
+ (pprint-eval-string-in-frame): Apply arguments in proper order.
+
+ * swank-cmucl.lisp (method-dspec): Include method-qualifiers.
+ (class-definitions): Renamed from struct-definitions. Try to
+ locate condition-classes and PCL classes (in the future).
+ (debug-function-arglist): Insert &optional, &key, &rest in the
+ right places.
+ (form-number-stream-position): Make it a separate function.
+
+2004-03-29 Lawrence Mitchell <wence(a)gmx.li>
+
+ * swank.lisp (ed-in-emacs): New allowed form for argument.
+
+ * slime.el (slime-ed): Deal with list form of argument. For a
+ list (FILENAME LINE [COLUMN]), visit the correct line and column
+ number.
+
+2004-03-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-source-path-parser.lisp (cmucl-style-get-macro-character):
+ New function. Workaround for bug(?) in SBCL.
+ (make-source-recording-readtable): Use it.
+
+2004-03-29 Luke Gorrie <luke(a)bluetail.com>
+
+ * HACKING: Some small updates (more needed).
+
+ * slime.el (slime-inspector-buffer): Enter `slime-inspector-mode'
+ after `slime-mode'. This seems to give priority of keymap to the
+ inspector, so that it can override SPC.
+ (slime-easy-menu): Add slime-switch-to-output-buffer.
+ Enable SLIME menu in the REPL buffer.
+ (slime-symbol-name-at-point): Avoid mistaking the REPL prompt for
+ a symbol.
+ (slime-words-of-encouragement): A few new ones.
+ (slime-insert-xrefs): Removed the final newline from XREF
+ buffers. This helps to avoid unwanted scrolling.
+
+ * doc/slime.texi: Added a section about user-interface
+ conventions and our relationship with inf-lisp.
+
+2004-03-27 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-changelog-date): Reinitialize it at load-time.
+ This avoids the need to restart Emacs (horror!) after an update.
+
+ * swank-cmucl.lisp (debug-function-arglist): Properly reconstruct
+ the arglist from the debug-info. (Not complete yet.)
+ (arglist): Use it.
+
+ * swank-lispworks.lisp (spawn): Remove CL symbols from
+ mp:*process-initial-bindings*, to avoid the irritating behavior
+ for requests executed in different threads. E.g., when someone
+ tries to set *package*.
+
+ * swank.lisp (*log-io*): New variable. Bind it to *terminal-io*
+ at load-time, so we can log to a non-redirected stream.
+ (disassemble-symbol): Allow generalized function names.
+ (apropos-symbols): Handle the PACKAGE argument properly to get
+ useful output for C-c P.
+
+ * slime.el (slime-repl-indent-and-complete-symbol): New command.
+ Bound to TAB in the REPL mode. First try to indent the current
+ line then try to complete the symbol at point.
+ (slime-dispatch-event): Ignore a unused thread variable to keep
+ XEmacs' byte compiler quiet.
+
+ * swank-sbcl.lisp (enable-sigio-on-fd): Use sb-posix::fcntl
+ instead of sb-posix:fcntl to avoid the ugly reader hack. SBCL
+ doesn't have package locks and even if they add locks in the
+ future sb-posix::fcntl will still be valid.
+ (getpid): Use defimplementation instead of defmethod.
+ (function-definitions): Take generalized function names ala '(setf
+ car)' as argument.
+
+2004-03-26 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-group-similar): Bugfix: return NIL if the input
+ list is NIL.
+ (slime-inspector-buffer): Enter `slime-inspector-mode' after
+ `slime-mode'. This seems to give priority of keymap to the
+ inspector, so that it can override SPC.
+
+2004-03-26 Bj�rn Nordb� <bn(a)telenor.net>
+
+ * swank.lisp (print-arglist): Updated to handle arglists with
+ string elements, causing arglists for macros to display properly
+ in LW 4.1.
+
+2004-03-26 Marco Baringer <mb(a)bese.it>
+
+ * swank-cmucl.lisp (set-default-directory): Define only once;
+ define with defimplementation, not defun.
+
+2004-03-26 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-merge-notes-for-display): New function to merge
+ together compiler notes that refer to the same location. This is
+ an optimization for when there are a lot of compiler notes:
+ `slime-merge-note-into-overlay' concat'd messages together one by
+ one in O(n^2) time/space, and became noticeably slow in practice
+ with ~100 notes or more.
+ (slime-tree-insert): This function is now automatically
+ byte-compiled (good speed gain).
+ Wrap byte-compilation in `save-window-excursion' to avoid showing
+ an unwanted warnings buffer (in XEmacs).
+
+2004-03-25 Bj�rn Nordb� <bn(a)telenor.net>
+
+ * swank-lispworks.lisp: (create-socket, set-sigint-handler)
+ (who-references, who-binds, who-sets): Add backward compatibility
+ for LW 4.1.
+ (dspec-buffer-position): Fix inappropriate use of etypecase.
+
+2004-03-24 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-sbcl.lisp (getpid): Use sb-posix:getpid.
+
+ * slime.el (slime-inspector-mode-map): Added SPC as extra binding
+ for slime-inspector-next (like info-mode).
+
+ * doc/slime.texi: Added completion style and configuration.
+
+2004-03-23 Alan Shutko <ats(a)acm.org>
+
+ * swank-clisp.lisp (set-default-directory): New function.
+
+2004-03-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp (send): Wait a bit if there are already many
+ message in the mailbox.
+
+ * swank-clisp.lisp (xref-results): Use fspec-location instead of
+ the of fspec-source-locations. Reported by Alan Shutko.
+ (break): Be friendly to case-inverting readtables.
+
+ * swank-lispworks.lisp (emacs-connected): Add default method to
+ environment-display-notifier. Reported by Bj�rn Nordb�.
+ (set-default-directory, who-specializes): Implemented for
+ Lispworks.
+ (gfp): New function.
+ (describe-symbol-for-emacs, describe-definition): Distinguish
+ between ordinary and generic functions.
+ (call-with-debugging-environment): Unwind a few frames. Looks
+ better and avoids the problems with the real topframe.
+ (interesting-frame-p): Use Lispworks dbg:*print-xxx* variables to
+ decide which frames are interesting.
+ (frame-actual-args): New function.
+ (print-frame): Use it.
+
+ * swank.lisp (open-streams, make-output-function): Capture the
+ connection not only the socket. This way the streams can be used
+ from unrelated threads. Reported by Alain Picard.
+ (create-connection): Factorized. Initialize the streams after the
+ connection is created.
+ (initialize-streams-for-connection, spawn-threads-for-connection):
+ New functions.
+ (with-connection): Fix quoting bug and move upwards before first
+ use.
+ (guess-package-from-string): Add kludge for SBCL !-package names.
+ (apropos-list-for-emacs): Lispworks apparently returns duplicates;
+ remove them.
+ (inspect-object): Princ the label to allow strings and symbols.
+ (send-output-to-emacs): Deleted.
+ (defslimefun-unimplemented): Deleted. Was unused.
+
+ * slime.el (slime-easy-menu): Add some more commands.
+ (slime-changelog-date): New variable. Initialized with the value
+ returned by the function of the same name. This detects
+ incompatible versions if Emacs has not been restarted after an
+ upgrade.
+ (slime-check-protocol-version, slime-init-output-buffer): Use it.
+ (slime-events-buffer, slime-log-event): Use fundamental mode
+ instead of lisp-mode to avoid excessive font-locking for messages
+ with lots of strings.
+
+2004-03-22 Luke Gorrie <luke(a)bluetail.com>
+
+ * doc/slime.texi: New user manual.
+
+ * swank.lisp (*communication-style*): New name for
+ *swank-in-background*.
+ Exported configuration variables: *communication-style*,
+ *log-events*, *use-dedicated-output-stream*.
+
+2004-03-20 Julian Stecklina <der_julian(a)web.de>
+
+ * swank-sbcl.lisp (+o_async+, +f_setown+, +f_setfl+): Add correct
+ constants for FreeBSD.
+
+2004-03-19 Alan Shutko <ats(a)acm.org>
+
+ * swank.lisp, swank-loader.lisp: Take into account
+ `pathname-device' when deriving paths. A fix for Windows.
+
+2004-03-19 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-connected-hook): New hook called each time SLIME
+ successfully connects to Lisp. This is handy for calling
+ `slime-ensure-typeout-frame', if you want to use that feature.
+ (sldb-print-condition): New command to print the SLDB condition
+ description into the REPL, for reference after SLDB exits. Can be
+ called from `sldb-hook' if you want the condition to always be
+ printed. Bound to 'P' in SLDB.
+
+2004-03-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (format-values-for-echo-area): Bind *package* to
+ *buffer-package*.
+ (load-system-for-emacs): Renamed from swank-load-system.
+ (carefully-find-package): Be friendly to case inverting
+ readtables.
+ (inspect-current-condition): New function.
+
+ * swank-backend.lisp, swank-cmucl.lisp (set-default-directory):
+ New backend function.
+
+ * swank-allegro.lisp, swank-clisp.lisp, swank-lispworks.lisp,
+ swank-sbcl.lisp (swank-compile-string): Be friendly to
+ case-inverting readtables.
+
+ * slime.el (sldb-inspect-condition): Use
+ swank:inspect-current-condition.
+ (slime-inspector-label-face): Make it bold by default.
+ (slime-check-protocol-version, slime-process-available-input):
+ Wait 2 secs after displaying the error message.
+ (sldb-list-catch-tags, sldb-show-frame-details): Display catch
+ tags as symbols not as strings.
+
+2004-03-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-dispatch-event, slime-rex): Pass a form instead
+ of a string with :emacs-rex.
+ (slime-connection-name): New connection variable. Use it in
+ various places instead of slime-lisp-implementation-type-name.
+
+ * swank.lisp: Better symbol completion for case-inverting
+ readtables. (Thanks Thomas F. Burdick for suggestions.)
+ (output-case-converter): New function.
+ (find-matching-symbols): Case convert the symbol-name before
+ comparing.
+ (compound-prefix-match, prefix-match-p): Use char= instead of
+ char-equal.
+ (case-convert-input): Renamed from case-convert.
+ (eval-for-emacs): Renamed from eval-string. Take a form instead
+ of a string.
+ (dispatch-event, read-from-socket-io): Update callers.
+ (eval-region, interactive-eval): Use fresh-line to reset the column.
+
+2004-03-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-space): Send a list of the operator names
+ surrounding point to Lisp. Lisp can use the list to select the
+ most suitable arglist for the echo area. Suggested by Christophe
+ Rhodes and Ivan Boldyrev.
+ (slime-enclosing-operator-names): New function.
+
+ * swank.lisp (arglist-for-echo-area): Renamed from arglist-string.
+ (format-arglist-for-echo-area, arglist-to-string): New functions.
+
+2004-03-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-backend.lisp (find-definitions): Fix docstring.
+
+ * slime.el (slime-dispatch-event): Re-enable :ed command.
+ (sldb-return-from-frame): Send swank:sldb-return-from-frame.
+
+ * swank-cmucl.lisp (find-definitions): Allow names like (setf car).
+
+ * swank.lisp (sldb-return-from-frame): Convert the string to a
+ sexp.
+ (dispatch-event, send-to-socket-io): Allow %apply events.
+ (safe-condition-message): Bind *pretty-print* to t.
+ (set-default-directory): Use the truename.
+ (find-definitions-for-emacs): Allow names like (setf car).
+
+2004-03-12 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * swank.lisp (:swank): Export startup-multiprocessing,
+ restart-frame, return-from-frame.
+ What about kill-thread and interrupt-thread, which are accessed
+ as internal symbols?
+
+2004-03-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (struct-definitions, find-dd)
+ (type-definitions, function-info-definitions)
+ (source-transform-definitions, setf-definitions): New funtions.
+ (find-definitions): Include struct definitions, deftypes, setf
+ defintions, compiler-macros and compiler transforms.
+
+2004-03-10 Andras Simon <andras(a)renyi.hu>
+
+ * swank.lisp (print-arglist): Use with-standard-io-syntax.
+
+2004-03-10 Pawel Ostrowski <pasza(a)zodiac.mimuw.edu.pl>
+
+ * swank-cmucl.lisp (unprofile-all): (eval '(profile:unprofile))
+ instead of just calling it since it is a macro in cmucl.
+
+ * swank.lisp (:swank): export profile symbols (profiled-functions,
+ profile-report, profile-reset, unprofile-all, profile-package)
+
+2004-03-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp, swank-lispworks.lisp, swank-sbcl.lisp,
+ swank-clisp.lisp, swank-cmucl.lisp (find-definitions): Some
+ tweaking.
+
+ * swank.lisp (print-arglist): Bind *pretty-circle* to nil to avoid
+ output like "(function . (cons))". Suggested by Michael Livshin.
+ (test-print-arglist): Re-enable the tests.
+ (find-definitions-for-emacs): Renamed from
+ find-function-locations.
+
+ * slime.el (slime-edit-definition): Renamed from
+ slime-edit-fdefinition. Display the dspec if there are multiple
+ definitions.
+ (slime-symbol-name-at-point): Handle the case when there is no
+ symbol at point.
+ (slime-expected-failures): New function
+ (slime-execute-tests): Use it.
+
+2004-03-09 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (frame-source-location-for-emacs): Export it.
+ Reported by Jouni K Seppanen
+ (test-print-arglist): Disable the tests until we know what's wrong
+ with print-arglist. Reported by Michael Livshin.
+
+ * swank-source-path-parser.lisp, swank-gray.lisp (in-package): We
+ are in-package :swank-backend. Thanks to Raymond Wiker.
+
+ Merge package-split branch into main trunk.
+
+ * swank-clisp.lisp (find-fspec-location): Handle "No such file"
+ errors.
+
+ * swank-openmcl.lisp (preferred-communication-style): Implemented.
+ (call-without-interrupts, getpid): Use defimplementation.
+ (arglist, swank-compile-file, swank-compile-string)
+ (swank-compile-system, backtrace): Renamed.
+ (print-frame): New function.
+ (frame-catch-tags): Don't exclude nil source location.
+ (format-restarts-for-emacs, debugger-info-for-emacs,
+ inspect-in-frame). deleted
+ (frame-arguments): Don't use to-string.
+ (find-source-locations, find-function-locations
+ (method-source-location): Deleted.
+ (canonicalize-location, find-definitions,
+ function-source-location, list-callers): Use
+ ccl::edit-definition-p and
+ ccl::get-source-files-with-types&classes. Makes things easier.
+ (return-from-frame): Take a sexp not a string.
+ (describe-definition): Describe more types.
+
+ * swank-loader.lisp: Change load order. swank.lisp is now the last
+ file.
+
+ * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp,
+ swank-gray.lisp, swank-lispworks.lisp, swank-sbcl.lisp,
+ swank-source-path-parser.lisp: Implement changed backend interface
+ and remove references to frontend symbols.
+
+ * swank-backend.lisp (:swank-backend): New package.
+ (definterface): Export the symbol.
+ (:location, :error, :position, :buffer): Define structure of
+ source locations here.
+ (preferred-communication-style, compute-backtrace, print-frame):
+ New functions.
+ (debugger-info-for-emacs): Deleted.
+
+ Renaming:
+
+ compile-file-for-emacs -> swank-compile-file
+ compile-string-for-emacs -> swank-compile-string
+ compile-system-for-emacs -> swank-compile-stystem
+ arglist-string -> arglist
+ backrace -> compute-backtrace
+ find-function-locations -> find-definitions
+
+ * swank.lisp (:swank): Create the package here.
+ (*swank-in-background*): Call the backend function
+ preferred-communication-style to for the initial value.
+ (find-symbol-designator): Handle NIL properly.
+ (arglist-string): Renamed from format-arglist. Call backend
+ function directly.
+ (*sldb-restarts*, swank-debugger-hook, format-restarts-for-emacs)
+ (nth-restart, invoke-nth-restart, sldb-abort): Handle restarts in
+ the front end.
+ (frame-for-emacs): Renamed from print-with-frame-label.
+ (backtrace, debugger-info-for-emacs, pprint-eval-string-in-frame)
+ (set-default-directory): Now in the front end.
+ (frame-locals-for-emacs): Use print not princ for variable names.
+ (compile-file-for-emacs, compile-string-for-emacs): Small wrappers
+ around backend functions.
+ (describe-definition-for-emacs): Handle unknown symbols before
+ calling the backend.
+ (find-function-locations): Wrapper for new backend function
+ find-definitions.
+ (group-xrefs, partition, location-valid-p, xref-buffer, xref):
+ Updated for the new backend functions.
+
+ * slime.el:
+ (slime-symbol-at-point, slime-symbol-name-at-point):
+ slime-symbol-at-point calls slime-symbol-name-at-point not the
+ other way around. This avoids the mess if the symbol at point is
+ NIL.
+ (slime-compile-file, slime-load-system, slime-compile-region)
+ (slime-call-describer, slime-who-calls, sldb-catch-tags): Updates
+ for renamed lisp functions.
+ (slime-list-callers, slime-list-callees): Unified with other xref
+ commands.
+ (sldb-show-frame-details): Catch tags no longer include the source
+ location.
+ (sldb-insert-locals): Simplified.
+
+2004-03-09 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (read-into-simple-string): Use the correct fix.
+ Reported by H�kon Alstadheim.
+
+2004-03-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-start-swank-server, slime-maybe-start-lisp):
+ Translate filenames. Reported by Dan Muller.
+
+2004-03-08 Bill Clementson <Bill_Clementson(a)peoplesoft.com>
+
+ * slime.el (slime-insert-balanced-comments)
+ (slime-remove-balanced-comments, slime-pretty-lambdas): New
+ functions.
+
+2004-03-07 Jouni K Seppanen <jks(a)iki.fi>
+
+ * slime.el (sldb-help-summary): New function.
+ (sldb-mode): Add docstring so that describe-mode is useful.
+ (sldb-mode-map): Add bindings for sldb-help-summary and
+ describe-mode.
+ (define-sldb-invoke-restart-key): Generate docstrings.
+ (sldb-default-action/mouse, sldb-default-action)
+ (sldb-eval-in-frame, sldb-pprint-eval-in-frame)
+ (sldb-inspect-in-frame, sldb-down, sldb-up, sldb-details-up)
+ (sldb-details-down, sldb-list-locals, sldb-quit, sldb-continue)
+ (sldb-abort, sldb-invoke-restart, sldb-break-with-default-debugger)
+ (sldb-step): Add rudimentary docstrings.
+
+2004-03-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-complete-symbol*, slime-simple-complete-symbol):
+ Use the correct block name when returning.
+ (slime-display-completion-list): Fix typo.
+
+ * swank-cmucl.lisp (frame-locals): Use #:not-available instead of
+ "<not-available>".
+
+2004-03-05 Bill Clementson <Bill_Clementson(a)peoplesoft.com>
+
+ * swank-lispworks.lisp (getpid, emacs-connected): Conditionalize
+ for Windows.
+
+2004-03-05 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (frame-locals-for-emacs): Bind *print-readably* to
+ nil.
+
+2004-03-05 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (frame-locals-for-emacs): New function.
+
+ * slime.el (sldb-frame-locals): Use swank::frame-locals-for-emacs
+ not swank::frame-locals.
+ (sldb-insert-locals): use the :value property, not the
+ :value-string property.
+
+ * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp,
+ swank-lispworks.lisp, swank-sbcl.lisp (frame-locals): Return lisp
+ objects, not strings. Use the :value property and not the
+ :value-string property.
+
+2004-03-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-display-comletion-list): New function. Set
+ syntax table properly.
+ (slime-complete-symbol*, slime-simple-complete-symbol): Use it.
+ (slime-update-connection-list): New function.
+ (slime-draw-connection-list): Simplified.
+ (slime-connection-list-mode-map): Bind g to update-connection-list.
+ (slime-open-inspector): Print the primitive type in brackets.
+ (slime-test-arglist): Add test for empty arglist.
+
+ * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp,
+ swank-lispworks.lisp, swank-sbcl.lisp, swank-backend.lisp
+ (thread-alive-p): Add default implementation.
+ (describe-primitive-type): Add default implementation.
+ (inspected-parts): Implemented for Allegro and CLISP.
+
+ * swank.lisp (remove-dead-threads): New function.
+ (lookup-thread): Use it.
+ (print-arglist): New function. This time without a custom pretty
+ print dispatch table.
+ (format-arglist): Use it.
+ (inspected-parts): Add method for hash-tables.
+
+2004-03-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp: Use *emacs-connection*, *active-threads*, and
+ *thread-counter* as thread local dynamic variables.
+ (init-emacs-connection): Don't set *emacs-connection*.
+ (create-connection, dispatch-event): Pass the connection object to
+ newly created threads.
+ (with-connection): New macro
+ (handle-request, install-fd-handler, debug-thread): Use it.
+
+ * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp,
+ swank-openmcl.lisp, swank-sbcl.lisp (call-with-compilation-hooks):
+ Bind fewer variables. Most of them are already bound in
+ swank.lisp.
+
+ * swank.lisp (setup-server, serve-connection): New dont-close
+ argument to keep the socket open after the first connection.
+ (start-server, create-swank-server): Update callers.
+ Reported by Bill Clementson.
+
+ * swank-cmucl.lisp (resolve-note-location): Don't be too clever,
+ if there is no context available. The compiler notes buffer is
+ probably more adequate in this situation.
+ (compile-file-for-emacs): Use the :load argument to compile-file.
+ (inspect-in-frame): Deleted.
+
+ * slime.el (slime-compilation-finished-hook): Use
+ slime-maybe-list-compiler-notes as default.
+ (slime-maybe-list-compiler-notes): New function.
+ (slime-list-compiler-notes): Insert "[no notes]" if there aren't
+ any. Pop to the buffer.
+ (slime-complete-symbol*, slime-simple-complete-symbol): Set the
+ lisp-mode-syntax-table in the completion buffer.
+ (check-parens): Compatibility function for XEmacs and Emacs 20.
+
+ * swank.lisp (find-completions): Deleted.
+ (simple-completions): Use longest-common-prefix instead of
+ longest-completion.
+ (inspect-in-frame): Moved here from swank-cmucl.lisp.
+
+ * swank-lispworks.lisp (call-with-debugging-environment): Bind
+ *sldb-top-frame*.
+ (nth-frame): Use *sldb-top-frame*.
+ (name-source-location, name-source-locations): Renamed from
+ dspec-source-location, dspec-source-locations. The result now
+ includes methods for generic functions.
+ (eval-in-frame, return-from-frame, restart-frame): Implemented.
+ (compile-string-for-emacs): Set dspec::*location* to the buffer
+ location.
+ (signal-undefined-functions, signal-error-data-base)
+ (make-dspec-location): Remove temp-file kludges.
+ (patch-source-locations, replace-source-file): Deleted.
+
+2004-03-01 Marco Baringer <mb(a)bese.it>
+
+ * swank.lisp (format-arglist): deal with nil arglists.
+
+2004-03-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp (compile-string-for-emacs): Patch the
+ recorded source locations.
+ (replace-source-file, patch-source-locations): New function.
+ (dspec-buffer-position): Handle defgeneric.
+ (make-dspec-location): Handle (patched) emacs-buffer locations.
+ (emacs-buffer-location-p): New function.
+ (describe-primitive-type, inspected-parts): Implemented.
+ (kill-thread): Implemented.
+
+ * swank-sbcl.lisp, swank-cmucl.lisp, swank-allegro.lisp
+ (kill-thread): Implemented.
+
+2004-02-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-complete-symbol): Make slime-complete-symbol
+ customizable. I don't understand how the ILISP style completion
+ is supposed to work and find it unintuitive.
+ (slime-complete-symbol-function): New variable.
+ (slime-complete-symbol*): Renamed from slime-complete-symbol.
+ (slime-simple-complete-symbol, slime-simple-completions): New
+ function.
+ (slime-compiler-notes-to-tree): Return a list of trees, not a single
+ tree.
+
+ * swank.lisp (format-arglist): Don't use a custom pprint table.
+ Didn't work with CLISP and the behavior was different in SBCL and
+ Lispworks.
+ (completions): Factorize.
+ (parse-completion-arguments, format-completion-set,
+ (completion-set, find-matching-symbols, find-completions): New
+ functions.
+ (simple-completions): New function.
+ (prefix-match-p) New function.
+
+2004-02-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-compilation-finished-hook): New hook variable.
+ (slime-compilation-finished): Call it.
+ (slime-maybe-show-xrefs-for-notes): New function.
+ (slime-make-default-connection): Use the current connection.
+ (slime-connection-at-point): New function.
+ (slime-goto-connection, slime-connection-list-make-default): Use
+ it.
+ (slime-draw-connection-list): Minor cleanups.
+
+ Define selectors for t and c for thread and connection list.
+
+ * swank.lisp: (*initial-pprint-dispatch-table*)
+ (*arglist-pprint-dispatch-table*): Workaround for bug in
+ CLISP. Don't supply nil as argument to copy-pprint-dispatch.
+ (print-cons-argument): Insert a space after the car.
+
+2004-02-27 Marco Baringer <mb(a)bese.it>
+
+ * slime.el (slime-read-port-and-connect,
+ slime-read-port-and-connect-to-running-swank): Refactor
+ slime-read-port-and-connect into two functions so that
+ slime-thread-attach can use the logic in
+ slime-read-port-and-connect.
+ (slime-thread-control-mode-map): Added key bindings for
+ slime-thread-kill, slime-thread-attach, slime-thread-debug and
+ slime-list-threads.
+ (slime-thread-kill, slime-thread-attach, slime-thread-debug): New
+ functions.
+
+ * swank-backend.lisp (kill-thread): Added to swank interface.
+
+ * swank-openmcl.lisp (kill-thread): Implement.
+
+ * swank.lisp (start-server): Add optional background argument,
+ defaults to *swank-background*.
+ (lookup-thread-by-id): New function.
+ (debug-thread): New function.
+
+2004-02-26 Peter Seibel <peter(a)javamonkey.com>
+
+ * slime.el (slime-draw-connection-list): Use text-properties to
+ associate the connections each line of the connections list
+ buffer.
+
+2004-02-26 Peter Seibel <peter(a)javamonkey.com>
+
+ * slime.el (slime-list-connections): Make the buffer created by
+ this function do a bit more: Can use it to switch to different
+ connections and change the default.
+
+2004-02-26 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (ccl::force-break-in-listener): Pass a
+ condition object to invoke-debugger.
+ Patch by Bryan O'Connor <bryan-slime(a)lunch.org>
+
+2004-02-26 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-backend.lisp (:swank): export connection-info.
+
+ * swank-allegro.lisp (lisp-implementation-type-name): Implement
+ it.
+
+ * swank-sbcl.lisp (compile-file-for-emacs): Load the fasl file
+ regardless of f-p.
+
+ * swank.lisp (swank-pprint): Bind *package* to *buffer-package*.
+ Reported by Alan Picard.
+
+ * swank-lispworks.lisp (dspec-buffer-position): Renamed from
+ dspec-buffer-buffer-position. Handle dspecs of the form (defmacro
+ foo). Reported by Alan Picard.
+ (arglist-string): Handle unknown arglists properly.
+
+2004-02-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (arglist-string): Delay the call to
+ di::function-debug-function until it is actually needed.
+ (compile-file-for-emacs): Load the fasl file irrespective of
+ COMILE-FILE's third return value.
+
+ * swank.lisp (connection-info): New function.
+ (open-streams): Don't send the :check-protocol-version message. Now
+ handled with CONNECTION-INFO.
+
+ * slime.el (slime-symbol-at-point): Don't skip backwards across
+ whitespace when we are at the first character of a symbol. To
+ handle this case: skip symbol constituents forward before skipping
+ whitespace backwards. Reported by Jan Richter.
+ (slime-connection-close-hook, slime-next-connection)
+ (slime-make-default-connection): Remove extra call to format.
+ (slime-init-connection-state): Use only a single RPC instead of 4.
+
+2004-02-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-with-chosen-connection): Bind
+ slime-dispatching-connection and not slime-buffer-connection.
+ slime-buffer-connection is a buffer local variable not a dynamic
+ variable.
+ (slime-find-connection-by-type-name)
+ (slime-read-lisp-implementation-type-name): Were lost during the
+ merge.
+ (sldb-fetch-more-frames): Use (goto-char (point-max)) instead of
+ end-of-buffer.
+
+2004-02-25 Peter Seibel <peter(a)javamonkey.com>
+
+ * slime.el: Various bits of support for maintaining multiple SLIME
+ connections to different Lisp implementations simultaneously.
+
+ * swank-backend.lisp (lisp-implementation-type-name): Add function to
+ return simple name of lisp implementation; used by new
+ multi-connection functionality in slime.el.
+
+2004-02-25 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (format-arglist): Use a special pprint-dispatch table.
+
+2004-02-22 Lawrence Mitchell <wence(a)gmx.li>
+
+ * swank.lisp (format-arglist): Bind *PRINT-PRETTY* to NIL.
+ (eval-in-emacs): Fix typo in docstring.
+
+ * swank-cmucl.lisp (arglist-string): Bind *PRINT-PRETTY* to NIL.
+
+2004-02-21 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ Add support for SERVE-EVENT based communication.
+
+ * swank-sbcl.lisp (add-sigio-handler, remove-sigio-handlers):
+ Renamed.
+ (add-fd-handler, remove-fd-handlers): Implement interface.
+
+ * swank-cmucl.lisp (fcntl): New function.
+ (add-sigio-handler, remove-sigio-handlers): Renamed.
+ (add-fd-handler, remove-fd-handlers): Implement interface.
+
+ * swank.lisp (create-connection): Add support for fd-handlers.
+ (install-fd-handler, deinstall-fd-handler): New functions.
+
+ * swank-backend.lisp (add-sigio-handler): Renamed from
+ add-input-handler.
+ (remove-sigio-handlers): Renamed from remove-input-handlers.
+ (add-fd-handler, remove-fd-handlers): New interface functions.
+
+ * slime.el (slime-batch-test): Use sit-for instead of
+ accept-process-output, so that we see something when swank gets
+ compiled. May be problematic in real batch mode.
+ (loop-interrupt-continue-interrupt-quit): Wait a second before
+ interrupting. The signal seems to arrive before the evaluation
+ request if don't wait => the endless loop is executed inside the
+ debugger and sldb-quit will not be processed with fd-handlers.
+
+ * swank.lisp (process-available-input): Move auxiliary function to
+ toplevel. Test if the stream is open.
+ (install-sigio-handler): Handle the first request after installing
+ the signal handler.
+
+ * slime.el (slime-keys): Bind C-c C-x t to slime-list-threads and
+ C-c C-x c to slime-list-connections.
+ (slime): Disconnect before reconnecting if the inferior-lisp
+ buffer wasn't renamed.
+ (slime-connect): Use the host argument and not "localhost".
+ (slime-compilation-finished): Undo last change. Switch to the
+ buffer to remove old annotations.
+ (slime-choose-overlay-region): Ignore errors in
+ slime-forward-sexp.
+
+2004-02-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime): Just close the connection when called without
+ prefix-argument. Keeping the connection open doesn't make sense.
+ We could ask if the Lisp process should be killed, though.
+ (slime-maybe-close-old-connections): Delete unused function.
+ (slime-start-swank-server): Use comint-send-string instead of
+ comint-proc-query, 'cause I don't like Olin "100%" Shivers' code.
+ (slime-init-output-buffer): Show some animations.
+ (slime-repl-clear-output): Fixed.
+ (slime-compilation-finished): It's not necessary to switch to the
+ original buffer, because the buffer is encoded in the
+ source-locations.
+ (sldb-show-source): Don't raise an error if the source cannot be
+ located. Print a message instead, because errors in
+ process-filters cause a 1 second delay.
+
+ * swank-cmucl.lisp (read-into-simple-string): Workaround for
+ read-sequence bug in 18e.
+
+2004-02-18 Peter Seibel <peter(a)javamonkey.com>
+
+ * swank-loader.lisp: Place the fasl files of different
+ implementations in different directories.
+
+2004-02-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-clisp.lisp: Update comments about metering package.
+
+ * metering.lisp: Imported from CLOCC. Suggested by Peter Seibel.
+
+2004-02-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp, slime.el (make-compiler-note): Don't send the
+ short-message across the wire if the slot is nil.
+
+ * swank-cmucl.lisp (clear-xref-info): Compare the truenames with
+ equalp instead of the unix-truenames. The old version was very
+ inefficient (clearing the tables with about 1000 entries required
+ serveral seconds).
+ (xref-context-derived-from-p, pathname=): Delete unused functions.
+
+ * swank-clisp.lisp (remove-input-handlers):
+ socket:socket-stream-handle is not available on Windows.
+ Reported by Alan Shutko.
+
+ * slime.el (slime-length>): New function.
+ (slime-compiler-notes-to-tree): Don't collapse if there is only
+ one kind of notes.
+
+2004-02-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (make-compiler-note): Include short-message.
+
+ * swank-sbcl.lisp (signal-compiler-condition): Initialize
+ short-message slot.
+ (long-compiler-message-for-emacs): New function.
+
+ * swank-cmucl.lisp (handle-notification-condition): Don't use the
+ context of the previous message.
+ (signal-compiler-condition): Set short message slot.
+ (long-compiler-message-for-emacs): New function.
+ (sigio-handler): Ignore arguments.
+
+ * swank-clisp.lisp (set-sigio-handler, add-input-handler):
+ Conditionalize for linux.
+
+ * swank-backend.lisp (compile-system-for-emacs): Add default
+ implementation.
+ (compiler-condition): New slot short-message.
+
+ * slime.el (slime-compilation-finished): Display compiler notes
+ grouped by severity in a separate buffer.
+ (slime-compilation-finished-continuation, slime-compile-file)
+ (slime-load-system, slime-compile-string): Update callers.
+ (slime-list-compiler-notes, slime-alistify, slime-tree-for-note)
+ (slime-tree-for-severity, slime-compiler-notes-to-tree)
+ (slime-compiler-notes-mode, slime-compiler-notes-quit): New
+ functions.
+ (with-struct, slime-tree): New code for pseudo tree widget.
+ (slime-init-connection-state): Set slime-state-name to "".
+
+2004-02-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (create-socket): Fix last fix. Use the proper
+ port argument.
+
+ * swank-allegro.lisp, swank-backend.lisp, swank-clisp.lisp,
+ swank-cmucl.lisp, swank-lispworks.lisp, swank-openmcl.lisp,
+ swank-sbcl.lisp (create-socket): Take interface as argument.
+
+ * slime.el (sldb-show-frame-details): Fix typos.
+ (slime-print-apropos): Don't bind action.
+ (slime-reset): Kill sldb-buffers.
+ (slime-test-find-definition, slime-test-complete-symbol)
+ (slime-test-arglist): Add more slime-check-top-level calls.
+
+ * swank.lisp (setup-server): Pass loopback-interface to
+ create-socket. Reported by Dirk Gerrits.
+ (*loopback-interface*): New parameter.
+ (sldb-loop): Send :debug event inside unwind-protect, so we never
+ lose the corresponding :debug-return event.
+
+2004-02-08 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp (find-source-locations): Eliminate unused
+ variable warning.
+
+ * swank.lisp (swank-pprint): Bind pretty print vars to
+ *swank-pprint-X* counter parts.
+ (*swank-pprint-circle*, *swank-pprint-escape*,
+ *swank-pprint-level*, *swank-pprint-length*): Swank counterparts
+ to *print-X* variables used when swank needs to pretty print a
+ form.
+ (apply-macro-expander): Use swank-pprint.
+
+2004-02-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (send, receive, interrupt-thread): Implement
+ more threading functions.
+
+ * swank-sbcl.lisp (inspected-parts): Implemented.
+
+ * slime.el (slime-rex): Mention thread argument in docstring.
+ (sldb-break-with-default-debugger): Use slime-rex and don't switch
+ to the output buffer (happens automatically).
+ (slime-list-threads): Renamed from slime-thread-control-panel.
+ (slime-thread-insert): Use slightly different layout.
+ (slime-give-goahead, slime-waiting-threads)
+ (slime-popup-thread-control-panel, slime-register-waiting-thread)
+ (slime-thread-goahead): Deleted.
+ (slime-maybe-start-multiprocessing): Call
+ swank:startup-multiprocessing. Reported by Paolo Amoroso.
+
+ * swank.lisp (dispatch-event): :debug, :debug-condition,
+ :debug-activate events were all encoded as :debug events, which
+ means the debugger never worked! Fix it. I guess no one uses
+ SLIME with a multithreaded Lisp.
+ (read-user-input-from-emacs): Flush the output before reading.
+ (sldb-loop): Add a sldb-enter-default-debugger tag, so we can
+ enter the default debugger by throwing to it.
+ (sldb-break-with-default-debugger): Throw to
+ sldb-enter-default-debugger.
+ (*thread-list*): New variable.
+ (list-threads): New function.
+
+ * swank-backend.lisp (thread-name): Take a thread object as
+ argument.
+ (thread-status, all-threads, thread-alive-p): New function.
+ (thread-id): Deleted.
+
+ * swank-allegro.lisp, swank-cmucl.lisp, swank-lispworks.lisp,
+ swank-openmcl.lisp, swank-sbcl.lisp: Update for modified thread
+ interface.
+
+ * swank-sbcl.lisp (enable-sigio-on-fd): New function. Use
+ fallback if sb-posix:fcntl isn't fbound.
+
+ * swank-cmucl.lisp (gf-definition-location): Return an error when
+ pathname for the GF is nil (this happens if the GF is not compiled
+ from a file).
+
+ * swank.lisp (undefine-function): New function.
+ (print-with-frame-label, print-part-to-string): Bind
+ *print-circle* to t, to avoid unbound recursion when printing
+ cyclic data structures.
+
+ * slime.el (slime-undefine-function): New command. Bound to C-c
+ C-u.
+
+2004-02-06 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (sldb-setup): Offer to enter a recursive edit if there
+ are pending continuations.
+ (slime-eval): Unwind the stack, thereby exititing recursive edits,
+ before signaling the error.
+
+2004-02-05 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-openmcl.lisp (compile-system-for-emacs): Remove compile
+ time dependency on ASDF.
+
+2004-02-05 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * swank-clisp.lisp, swank-loader.lisp: Add profiling support via
+ Kantrowitz's metering package. Reporting needs to be
+ refined (profile-package currently ignores callers-p and methods).
+
+2004-02-04 Bryan O'Connor <bryan-slime(a)lunch.org>
+
+ * swank-openmcl.lisp (mailbox): Use a semaphore instead of
+ process-wait. Works better with native threads.
+
+2004-02-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-backend.lisp (debugger-info-for-emacs): Export it.
+
+ * swank-sbcl.lisp (add-input-handler): Use fcntl from the sb-posix
+ package.
+
+ * swank.lisp (sldb-loop, dispatch-event, send-to-socket-io): Send
+ a :debug-activate event instead of a :debug event (to avoid
+ sending a potentially long backtrace each time).
+ (handle-sldb-condition): Include the thread-id in the message.
+
+ * slime.el (slime-path): Use load-file-name as fallback.
+ Suggested by Lawrence Mitchell.
+ (slime-dispatch-event): Add support for :debug-activate event.
+ (sldb-activate): New function.
+ (sldb-mode): make-local-hook doesn't seem to work in Emacs 20.
+ Use a buffer local variable instead.
+ (slime-list-connections): Don't print Lisp's state.
+ (slime-short-state-name): Deleted.
+
+2004-02-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-debugger): The customization group is called
+ 'slime-debugger', fix referrers. Reported by Jouni K Seppanen.
+
+ * swank.lisp (simple-break): Bind *debugger-hook* before invoking
+ the debugger. Reported by Michael Livshin.
+
+2004-01-31 Robert E. Brown <bbrown(a)speakeasy.net>
+
+ * swank-sbcl.lisp, swank.lisp: Add more type declarations and
+ detect missing initargs for the connection struct.
+
+2004-01-31 Jouni K Seppanen <jks(a)iki.fi>
+
+ * slime.el (slime-path): Placed inside an eval-and-compile. Works
+ around some problems when byte-compiling slime-changelog-date.
+
+2004-01-31 Marco Baringer <mb(a)bese.it>
+
+ * swank-openmcl.lisp: remove defslimefun-unimplemented forms.
+ (call-with-compilation-hooks, compile-system-for-emacs): Implement
+ them.
+ (compile-file-for-emacs, compile-string-for-emacs): Use
+ with-compilation-hooks.
+ (list-callers): Define with defimplementation and not defslimefun.
+
+ * swank-backend.lisp (compile-system-for-emacs): Declare method
+ as part of the interface.
+
+ * slime.el (slime-find-asd): Handle files whose directory does
+ not contain an asdf system definition.
+
+2004-01-31 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ Merge stateless-emacs branch into main trunk. We use now signal
+ driven IO for CMUCL and one thread per request for multithreaded
+ Lisps.
+
+2004-01-31 Robert E. Brown <bbrown(a)speakeasy.net>
+
+ * swank-backend.lisp, swank-sbcl.lisp,
+ swank-source-path-parser.lisp, swank.lisp: Add type declarations
+ to keep SBCL quiet.
+
+2004-01-29 Michael Weber <michaelw+slime(a)foldr.org>
+
+ * slime.el, swank-backend.lisp, swank-cmucl.lisp, swank-sbcl.lisp,
+ swank.lisp: Profiler support.
+
+2004-01-23 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-openmcl.lisp: Bind ccl::*signal-printing-errors* to nil
+ inside debugger so that error while printing error take us down.
+
+2004-01-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-sbcl.lisp (eval-in-frame, return-from-frame): Implemented.
+ (sb-debug-catch-tag-p): New auxiliary predicate.
+ (source-path<): Delete unused function.
+
+2004-01-23 Michael Weber <michaelw(a)foldr.org>
+
+ * slime.el (slime-keys): Bind C-c M-p to slime-repl-set-package.
+ (slime-easy-menu): Add entry for slime-repl-set-package.
+
+2004-01-23 Michael Weber <michaelw(a)foldr.org>
+
+ * slime.el (slime-repl-set-package): New command to set the
+ package in the REPL buffer.
+
+ * swank.lisp (set-package): Return the shortest nickname.
+
+2004-01-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (sldb-disassemble): Was lost somewhere.
+
+2004-01-22 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * swank-clisp.lisp: Replace defmethod by defimplementation where
+ appropriate.
+ (return-from-frame, restart-frame): Implement them.
+
+2004-01-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * test.sh: Copy the ChangeLog file too.
+
+ * swank-cmucl.lisp: Replace some defmethods with
+ defimplementation.
+
+ * swank-allegro.lisp (return-from-frame, restart-name): Implement
+ interface (partly).
+
+ * swank-openmcl.lisp (restart-frame, return-from-frame): Remove
+ sldb-prefix.
+
+ * swank-backend.lisp (return-from-frame, restart-frame):
+ Are now interface functions.
+
+ * swank.asd: Remove dependency on :sb-bsd-sockets. Is already
+ done in swank-sbcl.
+
+ * swank-loader.lisp: Don't reference the swank package at
+ read-time.
+
+ * swank.lisp (completions): Never bind *package* to nil. That's a
+ type error in SBCL.
+ (swank-debugger-hook): Flush the output streams and be careful
+ when accessing *buffer-package*.
+ (create-swank-server): Return the port of the serve socket.
+
+ * swank-lispworks.lisp (interesting-frame-p): Don't print catch
+ frames.
+ (make-sigint-handler): New function.
+ (emacs-connected): Use it.
+
+ * slime.el (slime-lisp-implementation-type): New per connection
+ variable.
+ (slime-handle-oob): Handle debug-condition event. Can be signaled
+ CMUCL when cannot produce a backtrace.
+ (slime-debugging-state): Don't pop up the debugger buffer an
+ activate events. Annoying.
+ (sldb-break-with-default-debugger): Switch to the output buffer
+ before returning to the tty-debugger.
+ (sldb-return-from-frame, sldb-restart-frame): Use slime-rex.
+ (slime-list-connections, slime-short-state-name): New functions.
+
+2004-01-20 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-complete-symbol): Insert the completed-prefix
+ before deleting the original text to avoid troubles with left
+ inserting markers.
+ (slime-symbol-start-pos): Skip backward across symbol
+ constituents.
+ (slime-evaluating-state): [:read-sring] Save the window
+ configuration.
+ (slime-read-string-state): Don't handle activate events
+ (troublesome if, e.g, complete-symbol is used from another
+ buffer). Restore the window configuration.
+ (slime-repl-read-string): Goto the end of buffer.
+ (slime-debugging-state): [:activate] Display the debugger buffer
+ if not visible.
+ (slime-to-lisp-filename, slime-from-lisp-filename)
+ (slime-translate-to-lisp-filename-function)
+ (slime-translate-from-lisp-filename-function, slime-compile-file)
+ (slime-goto-location-buffer, slime-ed, slime-load-file): Support
+ for remote filename translation (untested).
+
+ * swank.lisp (create-swank-server): Take announce-fn as optional
+ argument.
+
+ * swank-allegro.lisp: Replace defmethod with defimplementation.
+ (eval-in-frame): Implemented.
+
+2004-01-20 Lasse Rasinen <lrasinen(a)iki.fi>
+
+ * slime.el (slime-prin1-to-string): Replacement for
+ prin1-to-string that avoids escaping non-ascii characters in a
+ way that the CL reader doesn't understand. Allows use of 8-bit
+ characters in Lisp expressions with Emacs in unibyte-mode.
+
+2004-01-20 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-eval-print-last-expression): Insert a newline
+ before and after the result.
+ (slime-easy-menu): Added menu items:
+ "Eval Region", "Scratch Buffer", "Apropos Package..."
+ Added some bold to default SLDB faces.
+
+2004-01-19 Alan Ruttenberg <alanr-l(a)mumble.net>
+ *swank-openmcl.lisp in frame-catch-tags, ppc32::catch-frame.catch-tag-cell -> 0,
+ ppc32::catch-frame.csp-cell -> 3. FIXME when this code is more stable in openMCL.
+
+2004-01-19 Michael Weber <michaelw(a)foldr.org>
+
+ * slime.el (slime-close-all-sexp): New command to close all
+ unmatched parens in the current defun. Bound to `C-c C-]'. With
+ prefix argument, only operate in the region (for closing
+ subforms).
+
+2004-01-19 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-openmcl.lisp (thread-id, thread-name): Fixed silly bugs
+ (thanks Marco Baringer).
+
+ * swank-loader.lisp: Call (swank:warn-unimplemented-interfaces).
+
+ * swank.lisp (ed-in-emacs): New command with the same interface
+ as CL:ED.
+
+ * swank-cmucl.lisp, swank-sbcl.lisp, swank-lispworks.lisp,
+ swank-openmcl.lisp, swank-allegro.lisp, swank-clisp.lisp: Updated
+ to use `defimplementation'.
+
+ * swank-backend.lisp (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.
+
+ * slime.el (sldb-enable-styled-backtrace): This is now true by
+ default.
+ (slime-keys): Bound `slime-inspect' to `C-c I'.
+ (slime): `M-x slime' now offers to keep existing connections
+ alive (else disconnect them). If you disconnect them, the new
+ connection gets to reuse the existing REPL.
+ (slime-connection): Error if the connection is closed.
+ (slime-handle-oob): New message (:ED WHAT) for `slime-ed'.
+ (slime-display-output-buffer): Don't pop up the REPL if it is
+ already visible in any frame.
+ (slime-find-asd): Handle case where (buffer-file-name) is nil.
+ (slime-ed): Elisp backend for (CL:ED WHAT).
+ (slime-apropos): Add a summary line to apropos listings.
+ (slime-print-apropos): Replaced `action' property (name of lisp
+ describe function) with `type' (argument to pass to unified
+ swank:describe-definition function).
+ (slime-apropos-package): New command on `C-c P'. Presents apropos
+ listing for all external (with prefix also internal) symbols in a
+ package.
+
+2004-01-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp (sigint-handler): Bind a continue restart.
+ (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 <alanr-l(a)mumble.net>
+
+ * 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 <wjenkner(a)inode.at>
+
+ * 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 <e9626484(a)stud3.tuwien.ac.at>
+
+ * 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.
+
+ * 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.
+ (inspected-parts-of-value-cell): Was lost during the inspector
+ refactoring.
+
+2004-01-18 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * 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 <e9626484(a)stud3.tuwien.ac.at>
+
+ * 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.
+
+ * swank-cmucl.lisp (arglist-string): Handle generic functions
+ better. Reported by Ivan Boldyrev.
+
+2004-01-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp: Multiprocessing support.
+
+ * 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.
+ (create-swank-server): Patch by Marco Baringer <mb(a)bese.it>.
+ 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 <luke(a)bluetail.com>
+
+ * 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.
+
+2004-01-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * 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 <luke(a)bluetail.com>
+
+ * 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 <wjenkner(a)inode.at>
+
+ * 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 <luke(a)bluetail.com>
+
+ * swank-openmcl.lisp (emacs-connected): Typo fix (missing
+ close-paren).
+
+2004-01-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * 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.
+
+ 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 <luke(a)bluetail.com>
+
+ * 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 <luke(a)bluetail.com>
+
+ * 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
+ 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.
+ (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 <wence(a)gmx.li>
+
+ * slime.el (slime-events-buffer): Set `hs-block-start-regexp'
+ before running `hs-minor-mode'.
+
+2004-01-10 Luke Gorrie <luke(a)bluetail.com>
+
+ * 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).
+
+2004-01-09 Luke Gorrie <luke(a)bluetail.com>
+
+ * 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.
+ (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 <e9626484(a)stud3.tuwien.ac.at>
+
+ * 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.
+
+ * swank-backend.lisp (debugger-info-for-emacs)
+ (find-function-locations): Doc fix.
+
+2004-01-09 Wolfgang Jenkner <wjenkner(a)inode.at>
+
+ * 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 <luke(a)bluetail.com>
+
+ * 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 <luke(a)bluetail.com>
+
+ * 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-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
+ additional *inferior-lisp* to connect to. Each connection now has
+ its own *slime-repl[<n>]* 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 <e9626484(a)stud3.tuwien.ac.at>
+
+ * 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 <i.mikalajunas(a)mbt.lt>
+
+ * swank-loader.lisp (user-init-file): Use merge-pathames. Fix
+ Windows support.
+
+2004-01-05 Luke Gorrie <luke(a)bluetail.com>
+
+ * 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 <e9626484(a)stud3.tuwien.ac.at>
+
+ * 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 <wjenkner(a)inode.at>
+
+ * 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 <alanr-l(a)mumble.net>
+ * slime.el 1.157
+ fix bug in sldb-princ-locals I introduced when adding fonts to sldb
+
+2003-12-19 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-openmcl.lisp 1.42
+ in request-loop register output stream to be periodically slushed per Gary Byer's email.
+ * slime.el 1.156
+ slime-goto-source-location. Sometimes source information is recorded but it isn't a standard "def"
+ in that case, don't error out, just look for the most likely place for the definition.
+
+2003-12-19 Luke Gorrie <luke(a)bluetail.com>
+
+ * null-swank-impl.lisp: Deleted this old file. See
+ swank-backend.lisp instead.
+
+2003-12-18 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * swank-openmcl.lisp 1.41
+ in openmcl (break) now goes into slime debugger.
+ (setq swank:*break-in-sldb* nil) to disable that.
+
+2003-12-17 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el 1.155
+ Allow font choices for backtrack. Add group for customizing them: sldb.
+ Whole thing is enabled with sldb-enable-styled-backtrace which is off by default, for now.
+ Try
+ '(sldb-condition-face ((t (:foreground "DarkSlateGray" :weight bold))))
+ '(sldb-detailed-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2))))
+ '(sldb-local-name-face ((t (:weight bold))))
+ '(sldb-restart-face ((t (:foreground "DarkBlue" :weight bold))))
+ '(sldb-restart-number-face ((t (:underline t :weight bold))))
+ '(sldb-restart-type-face ((t (:foreground "DarkSlateGrey" :weight bold))))
+ '(sldb-section-face ((t (:weight bold :height 1.2))))
+ '(sldb-selected-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2))))
+ '(sldb-topline-face ((t (:foreground "brown" :weight bold :height 1.2))))
+
+2003-12-17 Alan Ruttenberg <alanr-l(a)mumble.net>
+ * slime.el 1.154
+ Allow some face choices in the inspector. Try
+ '(slime-inspector-label-face ((t (:weight bold))))
+ '(slime-inspector-topline-face ((t (:foreground "brown" :weight bold :height 1.2))))
+ '(slime-inspector-type-face ((t (:foreground "DarkRed" :weight bold))))
+ You can also set slime-inspector-value-face
+
+2003-12-17 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-openmcl.lisp 1.40
+ Fix an error with frame-source-location-for-emacs when the
+ function was a method-function.
+ Defined method-source-location that handles this case. You can
+ still end up looking at the wrong definition, as the protocol
+ doesn't allow passing back the qualifiers and specializers to look
+ up the correct one in the file
+
+. * swank-openmcl.lisp 1.39
+ Allow you to continue after interrupting.
+ Properly set *swank-debugger-stack-frame* when interrupting.
+
+ * slime.el 1.152
+ sldb-continue now uses slime-oneway-eval
+
+2003-12-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Better handling of asynchronous output.
+ (slime-output-end): New variable. Use this marker to insert
+ output. Insert asynchronous output inserted before the "input
+ region" and before the prompt.
+ (slime-show-last-output): Use it.
+ (slime-repl-insert-prompt): Initialize it.
+ (slime-last-output-start): Removed.
+ (slime-flush-output): Increase delay to 20 usecs.
+ (slime-with-output-end-mark): Renamed from
+ slime-with-output-at-eob. Insert a newline if needed.
+ (slime-output-string, slime-repl-activate): Use it.
+ (slime-repl-return): Ensure that slime-repl-input-end-mark points
+ to a reasonable location.
+
+2003-12-17 Luke Gorrie <luke(a)bluetail.com>
+
+ * HACKING: New file summarising our way of working.
+
+2003-12-16 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-lisp-preferred-package-nicknames): Removed. Not
+ very interesting (and slightly broken) now that shortest-nicknames
+ are automatically used.
+ (slime-output-oneway-evaluate-request): New function to evaluate
+ an expression for side-effects (without getting a
+ result).
+ (slime-idle-state): Handle new :emacs-evaluate-oneway.
+ (slime-debugging-state): Handle :emacs-evaluate-oneway.
+ (sldb-invoke-restart): Use slime-oneway-eval. This avoids pushing
+ an evaluating state (which will be aborted, and print an unnecessary
+ message saying so).
+ (sldb-break-with-default-debugger): New command to break into the
+ default TTY debugger. Bound to 'B' in *sldb*.
+ (slime-read-string-state): Added :emacs-evaluate-oneway.
+
+ * swank.lisp (invoke-nth-restart-for-emacs): Wrapper around
+ INVOKE-NTH-RESTART that checks that Lisp and Emacs agree on the
+ debug level. This detects and ignores old restart requests when
+ several are sent at once (possible because of new oneway-eval
+ feature).
+ (oneway-eval-string): New function to evaluate a string without
+ sending a result, and with *DEBUGGER-HOOK* bound to NIL. (The
+ debugger hook is inhibited to avoid state conflicts.)
+
+2003-12-15 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-openmcl.lisp (ccl::*warn-if-redefine-kernel*): Support for
+ interrupting the listener (by Alan Ruttenberg).
+
+2003-12-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp *start-swank-in-background*: Set to t by default.
+
+ * slime.el (slime-eval-last-expression-display-output): New
+ command. Bound to C-x M-e. Suggested by Nicolas Neuss.
+ (slime-display-output-buffer): New function.
+ (slime-slime-compile-file): Use it.
+
+2003-12-15 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (*processing-rpc*, *multiprocessing-enabled*,
+ *debugger-hook-passback*): New variables.
+ (with-conversation-lock, with-I/O-lock): New macros.
+ (read-next-form): Use with-I/O-lock.
+ (send-to-emacs): Use with-I/O-lock.
+ (swank-debugger-hook): When called asynchronously (i.e. not
+ during RPC) and multiprocessing is enabled, suspend until
+ acknowleged by Emacs.
+ (install-global-debugger-hook): Install a SLIME-DEBUGGER-FUNCTION
+ globally on *DEBUGGER-HOOK*.
+ (startup-multiprocessing-for-emacs): Called to initialize multiprocessing.
+ (eval-string): Dynamically set the *PROCESSING-RPC* flag.
+ (eval-string): Nasty hack with *DEBUGGER-HOOK-PASSBACK* to
+ install debugger hook. Temporary, I swear!
+ (eval-region, shortest-package-nickname): Report the shortest
+ package nickname to Emacs (for the REPL prompt). Patch from Marco
+ Baringer.
+
+ * swank-backend.lisp: Defined multiprocessing interface.
+
+ * swank-cmucl.lisp: Implmemented the multiprocessing interface.
+
+ * slime.el (slime-multiprocessing): When true, use
+ multiprocessing in Lisp if available.
+ (slime-global-debugger-hook): When true, globally set
+ *debugger-hook* to use the SLIME debugger. For use with
+ SERVE-EVENT and multiprocessing.
+ (slime-handle-oob): Handle :AWAITING-GOAHEAD message from threads
+ that have suspended to wait for Emacs's attention.
+ (slime-give-goahead): New command to allow a suspended thread to
+ continue (bound to RET in the thread-control-panel).
+ (slime-thread-control-panel): New command to display a buffer
+ showing all threads that are suspending waiting for Emacs's
+ attention. Bound to `C-c C-x t'.
+ (slime-popup-thread-control-panel): When true, automatically
+ popup the thread-control buffer when a new thread suspends.
+
+2003-12-14 Alan Ruttenberg <alanr-l(a)mumble.net>
+
+ * swank-openmcl.lisp (eval-in-frame, inspect-object and friends):
+ Most of this is copied from swank-cmucl. The parts between &&&&&
+ are what I added for openmcl. I piggyback off the inspector which
+ is shipped with openmcl, so inspecting won't look the same as it
+ would in cmucl, I imagine. Still, it's a start. eval in frame
+ uses frame-locals to get bindings so if you have debug settings
+ low or don't have *save-local-symbols* set you won't be able to
+ evaluate.
+
+2003-12-14 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp (tracedp, toggle-trace-fdefinition): Moved
+ to swank.lisp.
+
+ * swank-allegro.lisp (create-swank-server): Add support for
+ BACKGROUND and CLOSE argument.
+ (call-with-debugging-environment): Use excl::int-newest-frame to
+ avoid the kludge with *break-hook*.
+ (sldb-abort): New function.
+ (frame-source-location-for-emacs): Dummy definition.
+ (compile-file-for-emacs): The argument is called
+ :load-after-compile and not :load.
+ (xref-results-for-emacs): Use dolist instead of loop.
+
+ * swank-openmcl.lisp (create-swank-server): Add support for
+ BACKGROUND and CLOSE argument.
+ (open-stream-to-emacs): Support for dedicated output stream.
+
+ * swank.lisp: *start-swank-in-background*,
+ *close-swank-socket-after-setup*, *use-dedicated-output-stream*:
+ Moved here from swank-cmucl.
+ (sldb-continue): Don't pass the condition as argument, because
+ that doesn't work with Allegro.
+ (toggle-trace-fdefinition, tracedp): Replace backend specific code
+ with portable, but ugly, calls to eval.
+
+ * swank-cmucl.lisp (compile-system-for-emacs): Add method for
+ CMUCL.
+
+ * slime.el (slime-goto-source-location): Better regexp for package
+ qualified symbols. Allow dashes in the name and two colons.
+ Reported by Alan Ruttenberg.
+
+2003-12-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-openmcl.lisp (create-swank-server): Interrupt the right
+ thread. Patch by Alan Ruttenberg. Not yet enabled, due to lack
+ of test platform.
+ (sldb-disassemble): Implement sldb-disassemble command. Patch by
+ Alan Ruttenberg.
+ Remove #' from lambdas.
+
+2003-12-12 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (create-swank-server): New keyword arguments to
+ control the server: BACKGROUND and CLOSE. fd-handlers are used if
+ BACKGROUND is true. If close CLOSE is true, close the socket
+ after the first connection; keep it open otherwise.
+ *start-swank-in-background*, *close-swank-socket-after-setup*: The
+ default values of the corresponding arguments for
+ create-swank-server.
+ (compile-file-for-emacs): Don't load the fasl-file when the
+ compilation failed.
+
+ * swank-openmcl.lisp (toggle-trace-fdefinition, tracedp):
+ Implement trace command. Patch by Alan Ruttenberg.
+ (find-function-locations, find-source-locations): Handle
+ variables, and method-combinations. General cleanups.
+ (source-info-first-file-name): Removed.
+ (list-callers): Fixed.
+ (list-callers): Fixed some more. method-name is not exported in
+ 0.14. From Marco Baringer.
+ (swank-accept-connection): Accept multiple connections. Patch by
+ Marco Baringer.
+
+ * swank-loader.lisp (user-init-file): Use homedir's truename.
+ Reported by Friedrich Dominicus.
+
+ * slime.el (slime-repl-current-input): Don't remove the final
+ newline if we are in reading state.
+ (slime-goto-source-location): Regex-quote the function-name and
+ handle package prefixes. Reported by Alan Ruttenberg.
+ (slime-output-string): Insert asynchronous output before the
+ prompt.
+
+2003-12-12 Daniel Barlow <dan(a)telent.net>
+
+ * swank-source-path-parser.lisp: new file, excerpting part of
+ swank-cmucl.lisp to where SBCL can find it as well.
+
+2003-12-11 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-one-line-ify): New function to convert
+ multi-line strings to one-liners by replacing any newline
+ followed by indentation by a single space.
+ (slime-xrefs-for-notes): Use it.
+
+2003-12-11 Daniel Barlow <dan(a)telent.net>
+
+ * swank-sbcl.lisp (compiler-note-location): replace with
+ thinly-ported version from the CMUCL backend which understands
+ :lisp as a pathname
+
+ * slime.el (slime-xrefs-for-notes): a little more temporary
+ variables, a little less cdr. Should be slightly faster on
+ big systems
+ (slime-goto-next-xref): set window point as well as buffer point -
+ now works in GNU Emacs 21.2.1
+
+ * swank.lisp (swank-compiler): new function abstracts commonality
+ between swank-compile-{file, string}.
+ (swank-load-system): call swank-compiler to load asdf system
+
+ * swank-sbcl.lisp (compiler-note-location and elsewhere):
+ remove all trace of *compile-filename*
+ (compile-*-for-emacs): shorten
+
+ * swank-backend.lisp (call-with-compilation-hooks): new GF
+ should set up all appropriate error condition loggers etc
+ to do a compilation preserving the notes. Implement for
+ sbcl, cmucl
+
+ * slime.el (slime-find-asd, slime-load-system): new command
+ to compile and load an ASDF system with all the usual compiler
+ notes and stuff
+ (slime-compilation-finished): if more than one file has new
+ errors/notes, create an xref buffer to show them all
+ (slime-remove-old-overlays): bug fix: now removes overlays even
+ at start of buffer
+ (slime-overlay-note): do nothing quietly if
+ slime-choose-overlay-region returns nil
+ (slime-choose-overlay-region): return nil if note has no location
+
+2003-12-11 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-repl-previous-prompt, slime-repl-next-prompt):
+ New commands. Suggested by H�kon Alstadheim.
+ (slime-repl-beginning-of-defun, slime-repl-end-of-defun): New
+ commands. Suggested by Andreas Fuchs.
+ (slime-repl-insert-prompt): Mark the prompt with a
+ slime-repl-prompt text property.
+ (slime-repl-eol): New function. Mostly for symmetry.
+ (slime-repl-in-input-area-p, slime-repl-at-prompt-end-p): New
+ predicates.
+ (slime-repl-find-prompt, slime-search-property-change-fn): New
+ functions.
+ (slime-ir1-expand): New command.
+
+ * swank-cmucl.lisp (accept-connection, request-loop): Don't use
+ fd-handlers. The code for the request-loop itself is now almost
+ the same as in the Allegro version.
+ (print-ir1-converted-blocks, expand-ir1-top-level): New functions.
+
+2003-12-10 Daniel Barlow <dan(a)telent.net>
+
+ * swank-sbcl.lisp (serve-request): more fiddling with serve-event
+ descriptors
+
+ * slime.el (slime-repl-return): slime-check-connected, otherwise
+ pressing Return in an unconnected repl gets a bit weird
+
+2003-12-10 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp,
+ swank-sbcl.lisp (create-swank-server): Accept an announce-function
+ keyword argument.
+
+ * swank.lisp (start-server): Pass an announce callback function to
+ create-swank-server. Works better with single threaded
+ implementations.
+ (announce-server-port, simple-announce-function): New functions.
+ (alistify): Doc fix.
+
+ * swank-cmucl.lisp (create-swank-server): Use announce callback.
+ (sldb-disassemble): New function.
+
+ * slime.el (sldb-disassemble): New command. Bound to D.
+
+2003-12-08 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-cmucl.lisp (*debug-definition-finding*): Now nil by
+ default, so that errors while looking for definitions are printed
+ as a message and not debugged.
+
+ * slime.el (slime-read-from-minibuffer): Now the only
+ completing-read function, stale ones deleted.
+
+2003-12-07 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-prune-initial-frames): Use regexp-heuristics and
+ the '--more--' token to avoid showing the user Swank-internal
+ backtrace frames initially.
+ (slime-repl-current-input): Don't include the final newline
+ character, to make backtraces prettier.
+ (slime-autodoc): Fixed annoying case where autodocs would be
+ fetched in a loop for undocumented symbols.
+
+ * swank.lisp (compound-prefix-match): New name and rewritten for
+ speed. Completion is much faster now.
+ (*sldb-initial-frames*): Send up to this many (default 20)
+ backtrace frames to Emacs when entering the debugger.
+
+2003-12-07 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp, swank-backend.lisp, swank-cmucl.lisp,
+ swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp
+ (function-source-locations): Make it at generic function.
+ (function-source-location-for-emacs): Removed. Fixes bug reported
+ by Marco Baringer.
+
+ * slime.el (slime-interactive-eval): Insert the result at point,
+ if called with prefix argument.
+
+2003-12-06 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-easy-menu): Added menubar support, contributed
+ by Friedrich Dominicus.
+
+2003-12-06 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-allegro.lisp: New file.
+
+ * swank-loader.lisp (user-init-file): Translate logical
+ pathnames. Reported by Friedrich Dominicus.
+
+ * swank-sbcl.lisp (handle-notification-condition): Don't ignore
+ warnings without context.
+ (compiler-note-location, brief-compiler-message-for-emacs,
+ compiler-note-location): Handle null context.
+ (compile-file-for-emacs): Bind *compile-filename* and load the
+ fasl file only if it exists.
+ (function-source-location): The name argument is now optional and
+ should be a symbol.
+ (find-function-locations): Return errors as a list of one error.
+ (call-with-debugging-environment): Set *print-level* to 4 and
+ *print-length* to 10. (Both where nil.)
+ (source-location-for-emacs): Fall back to the location of the
+ function, if there is no debug-block-info.
+ (safe-source-location-for-emacs): Don't catch all conditions; only
+ errors.
+ *compile-filename*: New variable
+ (open-listener): Don't make the socket non-blocking.
+
+ * slime.el (slime-eval/compile-defun-dwim): New command.
+ Suggested by "jan" <janmar(a)iprimus.com.au>.
+
+2003-12-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-debugging-state): Don't set sldb-level after
+ sldb-setup. Breaks the test-suite.
+ (slime-eval-defun): Fix typos.
+ (slime-xref-buffer, slime-goto-next-xref): Updated for the new
+ xref code.
+ (sldb-inspect-in-frame): Query with the sexp at point as initial
+ value.
+ (sldb-step): New command. Bound to s.
+
+ * swank-cmucl.lisp (format-frame-for-emacs, compute-backtrace,
+ backtrace): Don't send CMUCL's frame numbers to Emacs, use our own
+ numbering.
+ (set-step-breakpoints, sldb-step): Lisp side of sldb-step command.
+
+2003-12-04 Luke Gorrie <luke(a)bluetail.com>
+
+ * hyperspec.el: Updated URL to point to a live copy of the
+ hyperspec at lispworks.com, because the one on xanalys.com has
+ disappeared. Patch from Vincent Arkesteijn on the ilisp-devel
+ mailing list.
+
+2003-12-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp (toggle-trace-fdefinition, tracedp): New
+ support functions for toggle-trace command. Written by Alain
+ Picard.
+ (compile-from-temp-file): Don't delete the binary file if there is
+ none.
+ (lispworks-severity): Map all ERRORs to :error.
+
+ * slime.el (slime-eval-defun): Use slime-re-evaluate-defvar if the
+ defun starts with "defvar". C-M-x in elisp does this too.
+ (slime-re-evaluate-defvar): Take the form as argument.
+
+2003-12-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-debugging-state): Initialize the sldb-buffer if
+ (/= sldb-level level).
+ (slime-who-specializes): New command.
+
+ * swank-cmucl.lisp (create-swank-server): Set reuse-address to t
+ by default.
+ (resolve-note-location): Add method for warnings in interpreted
+ code.
+ (who-specializes): New function.
+ (dd-source-location): Handle case without constructors more
+ correctly.
+ (source-path-source-position): Skip ambigous entries in
+ source-map.
+ (source-location-from-code-location): Simplified.
+
+2003-12-03 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-completing-read-internal): Fix from Sean
+ O'Rourke.
+
+2003-12-02 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-sbcl.lisp (find-function-locations): Return a non-empty
+ list of source locations.
+
+ * slime.el (slime-with-xref-buffer): Remove spurious comma. (Bug
+ reported by Raymond Wiker). Some reordering of the xref code.
+
+ * swank.lisp (documentation-symbol): New optional argument for
+ return value if the symbol is not documented.
+
+2003-12-02 Sean O'Rourke <sorourke(a)cs.ucsd.edu>
+
+ * slime.el: (slime-repl-{clear-buffer,clear-output}): clear the
+ last and entire output in the *slime-repl* buffer
+ (slime-documentation): pop up a buffer with a symbol's
+ documentation instead of its description, if found.
+ (slime-complete-symbol): tweak the completion, taken from ilisp, to
+ complete filenames inside strings.
+ (slime-set-default-directory): also set *slime-repl*'s
+ default-directory, so e.g. find-file makes sense.
+
+2003-12-02 Daniel Barlow <dan(a)telent.net>
+
+ * slime.el (slime-with-xref-buffer): moved further up the file so
+ it's defined before slime-show-xrefs needs it
+
+ * swank-sbcl.lisp (function-source-location-for-emacs): return a
+ list of source locations (one per method) when the request is
+ for a GF. This seems to make the elisp side popup a window
+ to let the user select one. Cool.
+
+2003-12-01 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-[cmucl,sbcl,openmcl,lispworks].lisp (invoke-nth-restart):
+ Use invoke-restart-interactively.
+
+ * slime.el (slime-create-note-overlay, slime-sexp-depth): The
+ 'priority' property is unused. Remove it.
+
+ * swank-openmcl.lisp (find-function-locations): Return all methods
+ for generic functions. Doesn't work very well if multiple methods
+ are in the same file.
+ (swank-accept-connection): Don't create an extra thread, call
+ request-loop directly.
+
+2003-12-01 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-repl-return): Goto end of input area before
+ inserting newline.
+ (slime-autodoc-message-ok-p): Test to see if a documentation
+ message should be printed (returns nil if the
+ minibuffer/echo-area is already being used).
+ (slime-symbol-at-point): Skip back over whitespace before
+ looking for the symbol.
+ (slime-autodoc-delay): New configurable to specify the delay
+ before printing an autodoc message (default 0.2 secs).
+ (slime-ensure-typeout-frame): New function to call create a
+ typeout frame unless it already exists. Suitable to run on
+ slime-mode-hook if you always want to have a typeout window.
+ (slime-log-events): When nil, don't log events to
+ *slime-events*. This works-around a problem Raymond Toy has when
+ starting SLIME under XEmacs. Still investigating..
+
+2003-11-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Rewrite the xref code to work with other source
+ locations.
+ (slime-edit-fdefinition): Use the xref window to display generic
+ functions with methods.
+ (slime-goto-source-location): New representation for source
+ locations. Drop old code.
+ (slime-list-callers, slime-list-callees): Use the xref window.
+ Remove the slime-select-* stuff.
+ (slime-describe-function): New command. Bound to C-c C-f.
+ Primarily useful in Lispworks.
+ (slime-complete-symbol): Display the completion window if the
+ prefix is complete but not unique.
+ (slime-forward-positioned-source-path): Enter the sexp only if the
+ remaining sourcepath is not empty.
+ (slime-read-symbol-name): New optional argument QUERY forces
+ querying.
+
+ * swank.lisp (group-xrefs): Handle unresolved source locations.
+ (describe-symbol): Print something sensible about unknown symbols.
+
+ * swank-cmucl.lisp: Use the new format for source locations.
+ (find-function-locations): New function. Replaces
+ function-source-location-for-emacs. Returns a list of
+ source-locations.
+ (resolve-note-location): Renamed from resolve-location.
+ Simplified.
+ (brief-compiler-message-for-emacs): Print the source context
+ (that's the thing after ==>).
+ (who-xxxx): Take strings, not symbols, as arguments.
+ (function-callees, function-callers): Use the same format as the
+ who-xxx functions. Support for byte-compiled stuff.
+ (code-location-stream-position): Try to be clever is the source
+ path doesn't match the form.
+ (call-with-debugging-environment): Bind *print-readably* to nil.
+
+ * swank-lispworks.lisp: Use the new format for source
+ locations. Implement the find-function-locations.
+ (list-callers, list-callers): New functions.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp: Use the new format for
+ source locations and implement find-function-locations (just calls
+ the old code).
+
+2003-11-29 Daniel Barlow <dan(a)telent.net>
+
+ * swank-sbcl.lisp (source-location-for-emacs):
+ sb-debug::print-description-to-string takes only two args, not
+ three. Now 'v' command works in sldb :-)
+
+ * slime.el (slime-idle-state): added :debug as a valid transition
+
+ * swank.lisp (slime-debugger-function): New. Returns a function
+ suitable for use as the value of *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. e.g. for Araneida:
+ PKG> (setf araneida:*restart-on-handler-errors*
+ (swank:slime-debugger-fucntion))
+
+2003-11-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Some tweaking to the REPL. slime-repl-input-end-mark
+ is now always left inserting and slime-mark-input-end
+ "deactivates" the end mark by moving it to the beginning of the
+ buffer.
+ (slime-goto-source-location): Next try for more uniform
+ source-locations. A source-location is now a structure with a
+ "buffer-designator" and "position-designator". The buffer-designator
+ open the file or buffer and the position-designator moves point to the
+ right position.
+ (slime-autodoc-mode): New command.
+ (slime-find-fdefinitions): Experimental support for generic functions
+ with methods.
+ (slime-show-xrefs, slime-insert-xrefs, slime-goto-xref): Rewritten to
+ work with more general source locations.
+
+ * swank.lisp: Structure definitions for source-locations.
+ (alistify, location-position<, group-xrefs): Utilities for xref
+ support.
+
+ * swank-cmucl.lisp (code-location-source-location): Renamed from
+ safe-source-location-for-emacs.
+ (code-location-from-source-location): Renamed from
+ source-location-for-emacs.
+ (find-fdefinitions, function-source-locations): New functions.
+ (safe-definition-finding): New macro.
+
+ * swank-lispworks.lisp: Xref support.
+ (make-dspec-location): Updated for the new source-location format.
+
+2003-11-29 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (complete-symbol, arglist): Updated test cases for new
+ completion interface.
+
+2003-11-28 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-complete-symbol): Use the new completion
+ support from the Lisp side. Don't obscure minibuffer input with
+ completion messages.
+
+ * completer.el: Dead and buried! Replaced by half a page of Common
+ Lisp. Thanks Bill Clementson for a motivational and well-deserved
+ taunt.
+
+ * swank.lisp (longest-completion): Compute the best partial
+ completion for Emacs.
+
+ * slime.el (slime-swank-port-file): Try (temp-directory),
+ temporary-file-directory, or "/tmp/", depending on what
+ is (f)bound.
+
+2003-11-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp (make-dspec-location): Handle logical
+ pathnames. Reported by Alain Picard.
+
+ * swank-sbcl.lisp, swank-cmucl.lisp: Support for output
+ redirection to an Emacs buffer via a dedicated network stream.
+ Can be enabled with *use-dedicated-output-stream*.
+
+ * swank.lisp (slime-read-string, eval-string): Flush *emacs-io*.
+ (eval-in-emacs): New function.
+
+ * slime.el: Support for output from a dedicated socket.
+ (slime-open-stream-to-lisp, slime-output-filter): New functions.
+ Reorganized REPL code a bit.
+ (slime-input-complete-p): Use vanilla forward-sexp, because
+ slime-forward-sexp sometimes caused endless loops.
+ (slime-disconnect): Close the output-stream-connection if present.
+ (slime-handle-oob): A new :%apply event. Executes arbitrary code;
+ useful for bootstrapping.
+ (slime-flush-output): New function.
+ (slime-symbol-end-pos): Didn't work at all in Emacs20. Just use
+ point until someone commits a proper fix.
+ Various uses of display-buffer: The second argument is different in
+ XEmacs.
+ (interrupt-bubbling-idiot): Reduce the timeout to 5 seconds.
+
+2003-11-27 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-swank-port-file): Use `temporary-file-directory'
+ instead of hardcoding "/tmp/".
+
+2003-11-27 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-lispworks.lisp: New backend.
+
+ * slime.el (slime-with-output-to-temp-buffer): Save the window
+ configuration in a buffer local variable instead on a global
+ stack.
+ (slime-show-last-output): Behavior customizable with
+ slime-show-last-output-function. Various tweaking for better
+ multi-frame support.
+
+ * swank-backend.lisp: List exported symbols explicitly.
+
+ * swank-cmucl.lisp (function-source-location): Better support for
+ generic functions.
+
+ * swank.lisp (briefly-describe-symbol-for-emacs): Don't return
+ unbound symbols.
+ (describe-symbol, describe-function): Support package-qualified
+ strings.
+
+ * swank-loader.lisp: *sysdep-pathnames*: Add Lispworks files.
+ (compile-files-if-needed-serially): Compile all files in a
+ compilation unit.
+
+2003-11-27 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-complete-symbol): Make a bogus alist out of the
+ completion set, for compatibility with XEmacs.
+
+ * completer.el: Stolen^Wimported from ILISP version 1.4. This is
+ one revision prior to their latest, where they added a (require)
+ for some other ILISP code. I backed down a revision to make it
+ stand-alone, but this may mean that putting SLIME in the load-path
+ before ILISP will break ILISP. So, beware.
+ (completer-message): Cut dependency on undefined ilisp constant
+ testing for xemacs.
+
+2003-11-27 Zach Beane <xach(a)xach.com>
+
+ * swank.lisp (completions): Complete compound symbols (see below).
+
+ * slime.el (slime-complete-symbol): Use `completer' package to
+ handle more sophisticated completions. This includes abbreviations
+ like "m-v-b" => "multiple-value-bind". It also (somewhat scarily)
+ redefines other standard Emacs completion functions with similar
+ capabilities. See commentary in completer.erl for details.
+
+2003-11-25 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-make-typeout-frame): New command to create a
+ frame where commands can print messages that would otherwise go to
+ the echo area.
+ (slime-background-message): Function for printing "background"
+ messages. Uses the "typeout-frame" if it exists.
+ (slime-arglist): Print arglist with `slime-background-message'.
+ (slime-message): Use typeout frame if it exists, but only for
+ multi-line messages.
+
+2003-11-25 Daniel Barlow <dan(a)telent.net>
+
+ * swank-sbcl.lisp: delete big chunk of leftover commented-out
+ code
+
+ * slime.el: arglist command to use slime-read-symbol-name,
+ not slime-read-symbol
+
+ * README: Minor updates for currency
+
+2003-11-24 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-backend.lisp (compiler-condition): Removed use of
+ :documentation slot option. That is not portable (to CMUCL 18e).
+
+ * swank.lisp (eval-string-in-frame): Fixed symbol-visibility
+ problem (thanks Lawrence Mitchell).
+
+ * swank-sbcl.lisp (function-source-location): Use TRUENAME to
+ resolve source file name (thanks Lawrence Mitchell).
+
+ * slime.el (slime-goto-source-location): Fixes when finding
+ definition by regexp: open the right file (was missed), and
+ tweaked regexp to match more 'def' forms - especially
+ `defmacro-mundanely' (hyphen wasn't allowed before).
+
+2003-11-23 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-fetch-more-frames): Call swank:backtrace instead
+ of (renamed) swank:backtrace-for-emacs.
+
+ * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated
+ to use new debugger interfaces in swank-backend.lisp.
+
+ * swank-backend.lisp (backtrace, eval-in-frame, frame-catch-tags,
+ frame-locals, frame-source-location-for-emacs): More interface
+ functions.
+
+ * slime.el (slime-goto-source-location): Added optional `align-p'
+ argument for :file and :emacs-buffer location types. This is for
+ OpenMCL - unlike CMUCL its positions are not character-accurate so
+ it needs to be aligned to the beginning of the sexp.
+ (slime-connect): Don't delete a random window when *inferior-lisp*
+ isn't visible.
+
+ * swank-cmucl.lisp: Tidied up outline-minor-mode structure and
+ added comments and docstrings.
+
+ * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated
+ to use new debugger interface in swank-backend.lisp.
+
+ * swank-backend.lisp (call-with-debugging-environment,
+ sldb-condition, debugger-info-for-emacs): More callbacks defined.
+
+ * swank.lisp: Tidied up outline-minor-mode structure, added
+ comments and docstrings.
+ (sldb-loop): Took over the main debugger loop.
+
+ * swank-openmcl.lisp: Updated after refactoring of other backends
+ (was broken).
+
+ * slime.el (slime-goto-source-location): Align at beginning of
+ sexp after (:file name pos) and (:emacs-buffer buffer pos).
+
+ * swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for
+ (documentation SYM 'class), CLHS says there isn't any 'class
+ documentation (and SBCL warns).
+
+ * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Refactored
+ interface through swank-backend.lisp for: swank-compile-file,
+ swank-compile-string, describe-symbol-for-emacs (apropos),
+ macroexpand-all, arglist-string.
+
+ * swank-backend.lisp: New file defining the interface between
+ swank.lisp and the swank-*.lisp implementation files.
+
+2003-11-22 Brian Mastenbrook <bmastenb(a)cs.indiana.edu>
+
+ * swank.asd: ASDF definition to load "swank-loader.lisp". This is
+ useful for starting the Swank server in a separate Lisp and later
+ connecting with Emacs. The file includes commentary.
+
+2003-11-22 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-connect): Slightly reordered some window
+ operations to ensure that *slime-repl* is popped up after `M-x
+ slime-connect'.
+ (slime-show-last-output): If the *slime-repl* buffer is already
+ visible in any frame, don't change anything.
+
+ * swank.lisp (listener-eval): Format results in *buffer-package*.
+ Exporting (CREATE-SWANK-SERVER <port>). This function can be
+ called directly to start a swank server, which you can then
+ connect to with `M-x slime-connect'. It takes a port number as
+ argument, but this can be zero to use a random available port.
+ The function always returns the actual port number being used.
+
+2003-11-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp: Better printing off return values. In the REPL
+ buffer we print now every value in a separate line and in the echo
+ area separated by a comma. We also print "; No value" for the
+ degenerated case (values). A new variable *sldb-pprint-frames*
+ controls the printing of frames in the debugger. (Thanks Raymond
+ Toy for the suggestions.)
+
+ * swank-cmucl.lisp (format-frame-for-emacs): Bind *pretty-print*
+ to *sldb-pprint-frames*.
+
+ * slime.el: Window configuration are now saved on a stack, not in
+ a single global variable.
+ (slime-with-output-to-temp-buffer) We use now our own version of
+ with-output-to-temp-buffer. The default version is painfully
+ incompatible between Emacs versions. The version selects the
+ temporary buffer and the behaivor of "q" is now more consistent
+ (as suggested by Jan Rychter).
+ (slime-connect): Hide the *inferior-lisp-buffer* when we are
+ connected.
+ sldb-mode-map: Bind n and p to sldb-down and sldb-up.
+ (slime-edit-fdefinition-other-window): New function. Suggested by
+ Christian Lynbech.
+
+ * swank-loader.lisp (user-init-file): There is now a user init
+ file (~/.swank.lisp). It is loaded after the other files.
+
+2003-11-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: [slime-keys] Override C-c C-r with slime-eval-region
+ (reported by Paolo Amoroso).
+
+ * swank-loader.lisp: Compile and load gray stream stuff for SBCL
+ and OpenMCL.
+
+ * swank-openmcl.lisp, swank-sbcl.lisp: Import gray stream symbols.
+ (without-interrupts*): New function.
+
+ * swank.lisp (send-to-emacs): Protect the write operations by a
+ without-interrupts, so that we don't trash the *cl-connection*
+ buffer with partially written messages.
+
+ * swank-cmucl.lisp (without-interrupts*): New function.
+
+ * swank-gray.lisp (stream-write-char): Don't flush the buffer on
+ newlines.
+
+ * slime.el: Add some docstring.
+ (interrupt-bubbling-idiot): New test.
+ [slime-keys]: Don't bind "\C- ". Problematic on LinuxPPC.
+
+2003-11-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Some tweaking for better scrolling in the *slime-repl*
+ buffer (suggested by Jan Rychter).
+ (slime-compile-file): Display the output buffer at the beginning.
+ (slime-show-last-output): Include the prompt so that window-point
+ is updated properly.
+ (slime-with-output-at-eob): Update window-point if the buffer is
+ visible.
+ (slime-state/event-panic): Include the *slime-events* and
+ *cl-connection* buffers in the report.
+
+ * swank-cmucl.lisp (sos/out): Don't flush the buffer on newlines.
+
+2003-11-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Imititate an "output-mark". Output from Lisp should
+ move point only if point is at the end of the buffer. (Thanks
+ William Halliburton for the suggestion.)
+ (slime-with-output-at-eob): New function.
+ (slime-output-string, slime-repl-maybe-prompt): Use it.
+
+ slime-repl-mode-map: Override "\C-\M-x".
+
+ An experimental scratch buffer:
+ (slime-eval-print-last-expression): New function.
+ (slime-scratch-mode-map, slime-scratch-buffer,
+ slime-switch-to-scratch-buffer, slime-scratch): New functions.
+
+ * swank-cmucl.lisp (resolve-location): Emacs buffer positions are
+ 1 based. Add 1 to the 0 based file-position.
+
+2003-11-13 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-connect): pop-to-buffer into *slime-repl* when
+ we connect.
+
+2003-11-13 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el, swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl: New
+ representation for "source-locations". Compiler notes have now a
+ message, a severity, and a source-location field. Compiler notes,
+ edit-definition, and the debugger all use now the same
+ representation for source-location. CMUCL does the source-path to
+ file-position translation at the Lisp side. This works better
+ with reader macros, in particular with backquote. The SBCL
+ backend still does the translation on the Emacs side. OpenMCL
+ support is probably totally broken at the moment
+
+2003-11-13 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-repl-previous-input, slime-repl-next-input):
+ When partial input has already been entered, the M-{p,n} REPL
+ history commands only match lines that start with the
+ already-entered prefix. This is comint-compatible behaviour which
+ has been requested. The history commands also skip over line
+ identical to the one already entered.
+ (slime-complete-maybe-restore-window-confguration): Catch errors,
+ so that we don't cause `pre-command-hook' to be killed.
+ (slime-truncate-lines): If you set this to nil, slime won't set
+ `truncate-lines' in buffers like sldb, apropos, etc.
+
+2003-11-12 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-show-description): XEmacs portability: don't use
+ `temp-buffer-show-hook'.
+ (slime-inspect): Use `(slime-sexp-at-point)' as default inspection
+ value (thanks Jan Rychter).
+
+2003-11-10 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-post-command-hook): Inhibit unless (still) in
+ slime-mode. Only call `slime-autodoc-post-command-hook' when
+ `slime-autodoc-mode' is non-nil.
+ (slime-setup-command-hooks): Use `make-local-hook' instead of
+ `make-local-variable'.
+
+2003-11-08 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: slime-highlight-face: Use the :inherit attribute if
+ possible.
+ (slime-face-inheritance-possible-p): New function.
+
+ * slime.el (slime-repl-return): Only send the current input to
+ Lisp if it is a complete expression, like inferior-slime-return.
+
+ * swank.lisp (completions): Use *buffer-package* if no other
+ package is given.
+
+ * slime.el: Remove the non-working face inheriting stuff.
+ Hardcode colors for slime-highlight-face and specify the :inherit
+ attribute for slime-repl-output-face. So Emacs21 will do the
+ right thing and the others get at least a customizable face.
+
+ * slime.el (slime-buffer-package): Try to find be the
+ package name before resorting to slime-buffer-package. Return nil
+ and not "CL-USER" if the package cannot be determined.
+ (slime-goto-location): Insert notes with a source path, but
+ without filename or buffername, at point. This can happen for
+ warnings during macro expansion. (The macro expander is a
+ interpreted function and doesn't have a filename or buffername.)
+ (slime-show-note): Display 2 double quotes "" in the echo area for
+ zero length messages. SERIES tends to signal warnings with zero
+ length messages.
+ (slime-print-apropos): Add support for alien types.
+
+ * swank-cmucl.lisp (briefly-describe-symbol-for-emacs): Add
+ support for alien types.
+ (source-path-file-position): Read the entire expression with a
+ special readtable. The readtable records source positions for
+ each sub-expression in a hashtable. Extract the sub-expression
+ for the source path from the read object and lookup the
+ sub-expression in the hashtable to find its source position.
+
+ * swank-sbcl.lisp (swank-macroexpand-all): Implemented.
+
+2003-11-06 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-autodoc-mode): When non-nil, display the
+ argument list for the function-call near point each time the point
+ moves in a slime-mode buffer. This is a first-cut; more useful
+ context-sensitive help to follow (e.g. looking up variable
+ documentation).
+ (slime-autodoc-cache-type): Cache policy "autodoc" documentation:
+ either nil (no caching), 'last (the default - cache most recent
+ only), or 'all (cache everything on symbol plists forever).
+
+ * slime.el: Convenience macros:
+ (when-bind (var exp) &rest body)
+ => (let ((var exp)) (when var . body))
+ (with-lexical-bindings (var1 ...) . body)
+ => (lexical-let ((var1 var1) ...) . body)
+
+ * slime.el (slime, slime-lisp-package): Reset `slime-lisp-package'
+ (the REPL package) when reconnecting.
+ (slime-buffer-package): Return `slime-lisp-package' when the
+ major-mode is `slime-repl-mode'.
+
+2003-11-04 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-read-string-state): Add support for evaluation
+ requests.
+ (slime-repl-read-break): New command.
+ alternative.
+ slime-keys: XEmacs cannot rebind C-c C-g. Use C-c C-b as an
+ alternative.
+ (slime-selector): XEmacs has no prompt argument for read-char.
+ (slime-underline-color, slime-face-attributes): Make face
+ definitions compatible with XEmacs and Emacs20.
+ (slime-disconnect): Delete the buffer of the socket.
+ (slime-net-connect): Prefix the connection buffer name with a
+ space to avoid accidental deletion.
+
+ * swank.lisp (slime-read-string): Send a :read-aborted event for
+ non-local exits.
+ (case-convert): Handle :invert case better.
+
+2003-11-03 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-display-message-or-view,
+ slime-remove-message-window): Display too long lines in a new
+ window. Add a temporary pre-command-hook to remove the multiline
+ window before the next command is executed.
+
+ (slime-complete-symbol): Save the window configuration before
+ displaying the completions and try to restore it later. The
+ configuration is restored when: (a) the completion is unique (b) there
+ are no completion. It is also possible to delay the restoration until
+ (c) certain characters, e.g, space or a closing paren, are inserted.
+
+ (slime-selector): Don't abort when an unkown character is pressed;
+ display a message and continue. Similiar for ?\?. Add a selector for
+ the *sldb* buffer.
+
+ (slbd-hook, sldb-xemacs-post-command-hook): Emulate Emacs'
+ point-entered text property with a post-command hook.
+
+ * swank.lisp (case-convert, find-symbol-designator): New
+ functions.
+
+ * swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp
+ (arglist-string): Don't intern the function name. Use
+ find-symbol-designator instead.
+
+2003-11-03 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-display-buffer-region): Hacked to fix completely
+ inexplicable XEmacs problems.
+
+2003-11-2 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * null-swank-impl.lisp, swank-cmucl.lisp, swank-openmcl.lisp,
+ swank.lisp: Input redirection works now on the line level, like a
+ tty. Output streams are now line buffered. We no longer compute
+ the backtrace-length.
+
+ * slime.el:
+ (slime-repl-read-mode, slime-repl-read-string, slime-repl-return,
+ slime-repl-send-string, slime-read-string-state,
+ slime-activate-state): Reorganize input redirection. We no longer
+ work on the character level but on a line or region; more like a
+ terminal. This works better, because REPLs and debuggers are
+ usually written with a line buffering tty in mind.
+ (sldb-backtrace-length, slime-debugging-state,
+ slime-evaluating-state, sldb-setup, sldb-mode, sldb-insert-frames,
+ sldb-fetch-more-frames): Don't use backtrace-length. Computing
+ the length of the backtrace is (somewhat strangely) an expensive
+ operation in CMUCL, e.g., it takes >30 seconds to compute the
+ length when the yellow zone stack guard is hit.
+
+2003-11-02 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-log-event): Added a *slime-events* buffer
+ recording all state machine events. The buffer uses hideshow-mode
+ to fold messages down to single lines.
+ (slime-show-source-location): Bugfix: only create source-highlight
+ overlay if the source was actually located.
+ (slime-selector): Renamed from `slime-select' because that
+ function name was already in use. Ooops!
+
+ * swank.lisp (eval-string): force-output on *slime-output* before
+ returning the result. This somewhat works around some trouble
+ where output printed by lisp is being buffered too long.
+
+ * slime.el (slime-lisp-package-translations): Association list of
+ preferred package nicknames, for the REPL prompt. By default maps
+ COMMON-LISP->CL and COMMON-LISP-USER->CL-USER.
+
+2003-11-01 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-select): Added an extensible "Select" command,
+ which I gather is a LispM/Martin-Cracauer knock-off. When invoked,
+ the select command reads a single character and uses that to
+ decide which buffer to switch to. New characters can be defined,
+ and the currently availables ones can be seen with '?'. I have not
+ assigned a key to Select, because it seems like a command that
+ should have a global binding. I would suggest `C-c s'.
+
+ * swank.lisp (*slime-features*): Variable remembering the FEATURES
+ list.
+ (sync-state-to-emacs): Update Emacs about any state changes -
+ currently this just means changes to the FEATURES list.
+ (eval-string): Call `sync-state-to-emacs' before sending result.
+ (eval-region): With optional PACKAGE-UPDATE-P, if the evaluation
+ changes the current package, tell Emacs about the new package.
+ (listener-eval): Tell `eval-region' to notify Emacs of package
+ changes, so that e.g. (in-package :swank) does the right thing
+ when evaluated in the REPL.
+
+ * slime.el (slime-repl-output-face, slime-repl-input-face): Face
+ definitions for output printed by Lisp and for previous REPL user
+ inputs, respectively. Defaulting the input face to bold rather
+ than underline, because it looks better on multi-line input.
+ (slime-handle-oob): Two new out-of-band messages
+ (:new-features FEATURES) and (:new-package PACKAGE-NAME). These
+ are used for Lisp to tell Emacs about changes to *FEATURES* and
+ *PACKAGE* when appropriate.
+ (slime-same-line-p): Better implementation (does what the name
+ suggests).
+ (slime-lisp-package): New variable keeping track of *PACKAGE* in
+ Lisp -- or at least, the package to use for the REPL.
+ (slime-repl-insert-prompt): The prompt now includes the package
+ name.
+ (slime-repl-bol): C-a in the REPL now stops at the prompt.
+ (slime-repl-closing-return): C-RET & C-M-m now close all open
+ lists and then send input in REPL.
+ (slime-repl-newline-and-indent): C-j in REPL is now better with
+ indentation (won't get confused by unmatched quotes etc appearing
+ before the prompt).
+
+2003-11-1 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-debugging-state): Save the window configuration
+ in a state variable.
+ sldb-saved-window-configuration: Removed.
+ (slime-repl-mode): Use conservative scrolling.
+ (slime-repl-insert-prompt): Set window-point after the prompt.
+ (slime-repl-add-to-input-history): Don't add subsequent duplicates to
+ the history.
+
+ * swank.lisp (slime-read-char): Flush the output before reading.
+ (listener-eval): Like eval region but set reader variables (*, **,
+ *** etc.)
+
+ * swank-openmcl.lisp, swank-sbcl.lisp: Implement stream-line-column.
+
+ * swank-cmucl.lisp (slime-input-stream-misc-ops): Renamed from
+ slime-input-stream-misc.
+
+2003-10-31 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-repl-mode-map): Bound `slime-interrupt' on both
+ C-c C-c and C-c C-g.
+
+ * swank.lisp (interactive-eval): Evaluate in *buffer-package*.
+
+ * slime.el: Tweaked debugger window management somewhat: the
+ window configuration is saved when the debugger is first entered
+ and then restored when the idle state is reached.
+
+2003-10-31 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: (slime-repl-read-mode, slime-repl-read-xxx): New minor
+ mode for stream character based input to Lisp.
+
+ * swank.lisp: *read-input-catch-tag*, take-input, slime-read-char:
+ Moved here from swank-cmucl.lisp.
+ (defslimefun, defslimefun-unimplemented): Move macro definitions to
+ the beginning of the file.
+
+ * swank-cmucl.lisp: (slime-input-stream, slime-input-stream-read-char,
+ lime-input-stream-misc): Character input stream from Emacs.
+ (slime-input-stream/n-bin): Removed.
+
+ * swank-openmcl.lisp, swank-sbcl.lisp: Gray stream based input
+ redirection from Emacs.
+
+2003-10-29 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el:
+ Beginnings of a REPL-mode.
+ Minor debugger cleanups.
+
+ * swank.lisp:
+ slime-read-error: New condition.
+ (read-next-form): Re-signal the conditions as slime-read-errors. And
+ check the result of read-sequence (i.e. detect CMUCL's read-sequence
+ bug).
+ (sldb-continue, throw-to-toplevel): Was more or less the same in all
+ backends.
+
+ * swank-openmcl.lisp, swank-sbcl.lisp, swank-cmucl.lisp:
+ (serve-request): Handle slime-read-errors and bind a
+ slime-toplevel catcher.
+
+ * swank-cmucl.lisp:
+ (sldb-loop): Flush output at the beginning.
+ (inspect-in-frame): New function.
+ (frame-locals): Don't send the validity indicator across wire. Too
+ cmucl specific.
+
+2003-10-29 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-net-sentinel): Only show a message about
+ disconnection if the inferior-lisp is still running.
+ (slime-interrupt, slime-quit): Only send the quit/interrupt
+ message to Lisp if it is in fact evaluating something for us. This
+ fixes a protocol bug reported by Paolo Amoroso. Added (require
+ 'pp).
+
+2003-10-28 James Bielman <jamesjb(a)jamesjb.com>
+
+ * null-swank-impl.lisp: New file.
+
+ * swank-openmcl.lisp: Pre-refactoring updates to the OpenMCL backend:
+ (map-backtrace): Renamed from DO-BACKTRACE.
+ (frame-source-location-for-emacs): New function.
+ (function-source-location-for-emacs): New function,
+
+ * swank-openmcl.lisp: Docstring updates/additions.
+
+2003-10-25 Luke Gorrie <luke(a)bluetail.com>
+
+ * Everywhere: Changed the connection setup to use a dynamic
+ collision-free TCP port. The new protocol is this:
+
+ Emacs calls (swank:start-server FILENAME) via the
+ listener. FILENAME is /tmp/slime.${emacspid}
+ Lisp starts a TCP server on a dynamic available port and writes
+ the port number it gets to FILENAME.
+ Emacs asynchronously polls for FILENAME's creation. When it
+ exists, Emacs reads the port number, deletes the file, and makes
+ the connection.
+
+ The advantage is that you can run multiple Emacsen each with an
+ inferior lisp, and the port numbers will never collide and Emacs
+ will always connect to the right lisp.
+
+ All backends are updated, but only CMUCL and SBCL are
+ tested. Therefore, OpenMCL is almost certainly broken just now.
+
+ * slime.el (inferior-slime-closing-return): New command that
+ closes all open lists and sends the result to Lisp. Bound to C-RET
+ and (for people who use C-m for RET) C-M-m.
+ (inferior-slime-indent-line): Improved indentation in the inferior
+ list buffer.
+
+2003-10-24 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (inferior-slime-return): Command bound to RET in
+ inferior-slime-mode: only send the current input to Lisp if it is
+ a complete expression (or prefix argument is given). Two reasons:
+ it makes the input history contain complete expressions, and it
+ lets us nicely indent multiple-line inputs. (Thanks Raymond Toy
+ for the suggestions.)
+
+2003-10-23 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-maybe-start-lisp): Restart inferior-lisp if the
+ process has died.
+
+ * swank-sbcl.lisp (accept-connection): Use a character stream to
+ match swank.lisp.
+
+2003-10-22 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp (setup-request-handler): Create a character
+ stream.
+ (read-next-form): Removed.
+
+ * swank.lisp (read-next-form, send-to-emacs): Assume *emacs-io* is
+ a character stream. Add the necessary char-code/code-char
+ conversions.
+
+ * slime.el: slime-keys: Add :sldb keywords for keys useful in the
+ debugger.
+ (slime-init-keymaps): Allow allow :sldb keywords.
+
+ inferior-lisp-mode-hook: Display the inf-lisp buffer if there is
+ some output.
+
+ (slime-process-available-input): Start a timer to process any
+ remaining input.
+ (slime-dispatch-event): The timer should take care of any lost
+ input. So don't process the available input here. Remove the
+ process-input argument.
+ (slime-push-state, slime-pop-state, slime-activate-state,
+ slime-idle-state, slime-evaluating-state): Update callers.
+ (slime-debugging-state): Remove the unwind-protect in the
+ :debug-return clause. Should not be necessary.
+
+ sldb-mode-map: Define more slime-mode keys.
+
+ (slime-time<, slime-time-add): Removed. Emacs-21 has equivalent time
+ functions.
+ (slime-sync-state-stack): Use Emacs-21 time-date functions.
+ (seconds-to-time, time-less-p, time-add): Compatibility defuns.
+
+2003-10-22 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime): With a prefix argument, prompt for the port
+ number to use for communication with Lisp. This is remembered for
+ future connections.
+
+2003-10-22 Hannu Koivisto <azure(a)iki.fi>
+
+ * slime.el (slime-space): Now allows one to insert several spaces
+ with a prefix argument.
+
+2003-10-21 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-space): Don't give an error when not connected,
+ to avoid feeping.
+
+ * swank-sbcl.lisp (swank-compile-string): Include only one
+ :SOURCE-PATH attribute in the plist, and replace the front element
+ with a 0 (fixes a problem probably due to recent hacks to the
+ elisp source-path lookups).
+
+ * slime.el (inferior-slime-mode): New minor mode for use with
+ `inferior-lisp-mode'. Defines a subset of the `slime-mode' keys
+ which don't clash with comint (e.g. doesn't bind M-{p,n}).
+ (slime-keys): List of keybinding specifications.
+ (slime-find-buffer-package): If we don't find the "(in-package" by
+ searching backwards, then try forwards too.
+
+ * swank.lisp (completions): Fixed semantics: should now consider
+ only/all completions that would not cause a read-error due to
+ symbol visibility. Also avoiding duplicates and sorting on
+ symbol-name.
+
+2003-10-20 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (completions): Slight change of semantics: when a
+ prefix-designator is package-qualified, like "swank:", only match
+ symbols whose home-package matches the one given - ignore
+ inherited symbols.
+
+ * slime.el: Updated test suite to work with the different backends:
+ (find-definition): Lookup definitions in swank.lisp.
+ (arglist): Lookup arglists of functions in swank.lisp.
+
+2003-10-20 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (interactive-eval): Make test case independent of
+ *print-case*.
+
+2003-10-20 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank-cmucl.lisp (clear-xref-info): Conditionalised
+ xref:*who-is-called* and xref:*who-macroexpands* with
+ #+CMU19. This makes SLIME compatible with CMUCL 18e, but also
+ disables the `who-macroexpands' command in any CMUCL version that
+ doesn't have the "19A" feature (which does break the command in
+ some snapshot builds that can actually support it).
+
+2003-10-20 Daniel Barlow <dan(a)telent.net>
+
+ * swank.lisp (*notes-database*): tyop fix
+
+ * swank-sbcl.lisp (throw-to-toplevel): select TOPLEVEL restart
+ instead of throwing to a catch that no longer exists
+
+ * slime.el: change some strings containing 'CMUCL' to more
+ backend-agnostic phrases
+
+2003-10-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el, swank-cmucl.lisp, swank.lisp: First shoot at input
+ redirection.
+
+ * swank-sbcl.lisp, swank-openmcl.lisp: Bind *slime-input* and
+ *slime-io* to dummy values.
+
+2003-10-19 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime): Connection setup is now asynchronous, with
+ retrying on a timer. This makes it possible to bring the server up
+ by hand while debugging. `M-x slime' while already connected will
+ cause the old connection to be dropped and a new one established.
+ (slime-disconnect): New command to disconnect from Swank, or
+ cancel asynchronous connection attempts when not yet connected.
+ (slime-state/event-panic): Illegal events in the communication
+ state machine now trigger a general panic that disconnects from
+ Lisp, and displays a message describing what has happened. This is
+ a bug situation.
+ (slime-connect): Print a message during connection attempts unless
+ the minibuffer is active (it's annoying to get messages while
+ trying to enter commands).
+
+2003-10-18 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Fix some bugs in the state machine and be a bit more
+ careful when processing pending input.
+ (slime-compile-region): New command.
+ Some more tests.
+
+2003-10-17 James Bielman <jamesjb(a)jamesjb.com>
+
+ * .cvsignore: Add OpenMCL and SBCL fasl file extensions.
+
+ * swank-openmcl.lisp (who-calls): Fix bug where we would try to
+ take the TRUENAME of NIL when source information isn't available
+ for a caller.
+ (backtrace-for-emacs): Clean up the backtrace code a bit in
+ preparation for implementing FRAME-LOCALS.
+ (frame-catch-tags): Implement a stub version of this.
+ (frame-locals): Implemented fully for OpenMCL.
+
+ * swank-loader.lisp (compile-files-if-needed-serially): Be a little
+ more verbose when compiling files.
+
+2003-10-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp, swank-sbcl.lisp, swank-openmcl.lisp,
+ swank-cmucl.lisp: Move more stuff to swank.lisp.
+
+2003-10-17 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-post-command-hook): Check that we are connected
+ before trying to process input.
+ (slime-net-connect): Handle `network-error' condition for XEmacs
+ 21.5. (Thanks Raymond Toy.)
+
+ * swank-sbcl.lisp: Report style-warnings separately from notes
+ (patch from Christophe Rhodes). Use REQUIRE to load sb-introspect
+ instead of loading the source file (requires the sb-introspect
+ library to be installed, which doesn't yet happen in the
+ sourceforge-lagged SBCL anoncvs, but does in the real one).
+
+ * slime.el (slime-style-warning-face): Added style-warnings, which
+ are between a warning and a note in severity. (Patch from
+ Christophe Rhodes).
+
+ * test.sh: When the test fails to complete, print "crashed"
+ instead of reporting nonsense.
+
+2003-10-17 James Bielman <jamesjb(a)jamesjb.com>
+
+ * swank.lisp (apropos-symbols): Change back to using the standard
+ 2-argument APROPOS-LIST and check symbols explicitly when
+ EXTERNAL-ONLY is true.
+ Move loading of sys-dependent backend code into 'swank-loader'.
+
+ * swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION*
+ into 'swank.lisp' to kill warnings about undefined variables.
+
+ * swank-openmcl.lisp (handle-compiler-warning): Use source position
+ instead of function name for warning locations.
+ (swank-compile-string): Compile into a temporary file instead of
+ using COMPILE so finding warning positions works when using C-c C-c.
+ (compute-backtrace): Don't display frames without a function.
+ (apropos-list-for-emacs): Implement APROPOS.
+ (who-calls): Implement WHO-CALLS.
+ (completions): Implement COMPLETIONS.
+ Use NIL instead of zero so FRESH-LINE does the right thing.
+
+ * slime.el (slime-maybe-compile-swank): Removed function---compile
+ the backend using 'swank-loader.lisp' instead.
+ (slime-backend): Changed default backend to 'slime-loader'.
+ (slime-lisp-binary-extension): Deleted as this is no longer needed.
+
+ * swank-loader.lisp: New file.
+
+2003-10-17 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-net-connect): Check that
+ `set-process-coding-system' is fbound before calling it. This is
+ needed in the XEmacs I built from sources.
+
+2003-10-17 Daniel Barlow <dan(a)telent.net>
+
+ * swank-sbcl.lisp: Transplanted Helmut's serve-event server to
+ replace the existing thread-using server. SLIME now has no
+ dependency on SB-THREAD
+
+ * slime.el (slime-find-buffer-package): handle errors from (read)
+ for the case where the buffer ends before the in-package form does
+ (slime-set-package): insert missing comma
+ (slime-goto-source-location): sbcl has a disagreement with emacs
+ over the meaning of a character position. Level up with
+ C-M-f C-M-b
+
+ * assorted typo fixes
+
+2003-10-16 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-forward-source-path): Improved somewhat. Seems
+ to work for all common cases except backquote. Backquote is
+ tricky, because the source-paths are based on the reader's
+ expansion, e.g.:
+ * (let ((*print-pretty* nil))
+ (print (read-from-string "`(a ,@(b c) d)")))
+ -->
+ (COMMON-LISP::BACKQ-CONS (QUOTE A)
+ (COMMON-LISP::BACKQ-APPEND (B C)
+ (QUOTE (D))))
+ Must investigate whether we need to write a hairy
+ backquote-traversing state machine or whether this is something
+ that could be fixed in CMUCL.
+
+ * swank*.lisp (with-trapping-compiler-notes): This macro is now
+ defined here, and expands to a call to the backend-defined
+ `call-trapping-compiler-notes' with the body wrapped in a
+ lambda. This is to avoid swank.lisp referring to macros in the
+ backends -- it gets compiled first so it thinks they're functions.
+
+ * slime.el (slime-swank-connection-retries): New default value is
+ `nil', which means unlimited retries (until user aborts). Retry
+ interval also reduced from once per second to four times per
+ second.
+
+2003-10-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank-cmucl.lisp, swank.lisp: Fix CMUCL support.
+
+2003-10-15 Daniel Barlow <dan(a)telent.net>
+
+ * swank.lisp: rearrange the backends. rename swank.lisp to
+ swank-cmucl.lisp, then create new swank.lisp which loads an
+ appropriate backend according to *features*. Next up,
+ identify common functions in the backends and move them
+ into swank.lisp
+
+2003-10-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Inspector support. list-callers, list-callees
+ implemented without xref.
+
+ * swank.lisp: Lisp side for inspector and list-callers,
+ list-calees. Better fdefinition finding for struct-accessors.
+
+
+2003-10-15 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-point-moves-p): Macro for executing subforms and
+ returning true if they move the point.
+
+ * test.sh: New file to run the test suite in batch-mode. Will need
+ a little extending to allow configuring the right variables to
+ work with non-CMUCL backends.
+
+ * slime.el: Set `indent-tabs-mode' to nil. This makes diffs look
+ better.
+ (slime-start-swank-server): Now passing the port number to
+ SWANK:START-SERVER.
+ (slime-evaluating-state): Debugging synchronous evaluations with
+ recursive edits now works.
+ (slime-forward-sexp): Added support for #|...|# reader comments.
+ (sldb-hook): New hook for entry to the debugger (used for the test
+ suite).
+ (slime-run-tests): Reworked the testing framework. Now presents
+ results in an outline-mode buffer, with only the subtrees
+ containing failed tests expanded initially.
+ (slime-check): Check-name can now be a string or
+ format-control. (Test cases have been updated to take advantage of
+ this.)
+ (compile-defun): This test case now works for the case containing
+ #|..|#
+ (async-eval-debugging): New test case for recursively debugging
+ asynchronous evaluation.
+
+2003-10-15 Daniel Barlow <dan(a)telent.net>
+
+ * README.sbcl: new file
+
+ * README: update for new backends, change of hosting provider
+
+ * swank-sbcl.lisp: new file.
+ New SWANK backend for Steel Bank Common Lisp, adapted from
+ swank.lisp with bits of swank-openmcl.lisp
+
+2003-10-12 Daniel Barlow <dan(a)telent.net>
+
+ * slime.el (sldb-mode-map): add mouse-2 clickability for areas
+ in sldb buffers covered by the sldb-default-action property:
+ restarts can now be mouse-activated
+
+2003-09-28 James Bielman <jamesjb(a)jamesjb.com>
+
+ * swank-openmcl.lisp: New file, a Slime backend for OpenMCL 0.14.x.
+ (condition-function-name): Figure out the name of methods correctly
+ instead of passing a list to Emacs.
+
+ * slime.el (slime-goto-location): Try to position notes based on
+ some (questionable) regex searching if the :FUNCTION-NAME property
+ is set. Used in the OpenMCL backend which does not support source
+ paths.
+
+2003-09-29 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el: Fairly major hacking.
+ Rewrote the evaluation mechanics: similar design but some macros
+ to make it look more like a push-down automaton (which it really
+ was!). Debugging Lisp no longer uses recursive edits, partly as a
+ side-effect and partly to see if it's better this way.
+ Removed the asynchronous-communication test cases that tested
+ something we decided not to do.
+ (slime-eval-string-async): Give a meaningful error message when
+ trying to make a request while already busy.
+ (slime-lisp-binary-extension): Uh oh, time to start taking out
+ gratuitous CMUCL-isms. This variable renamed from
+ `slime-cmucl-binary-extension'.
+ (slime-backend): Name of the Lisp backend file, defaulting to
+ "swank", but can be set to e.g. "swank-openmcl".
+
+ * swank.lisp: Minor protocol changes to accomodate slime.el's
+ changes above.
+
+2003-09-28 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp
+ (getpid, set-package, set-default-directory): New functions.
+ (slime-out-misc): Don't send empty strings.
+ (*redirect-output*, read-from-emacs): A new switch to turn output
+ redirection off. Useful for debugging.
+ (interactive-eval, interactive-eval-region, pprint-eval,
+ re-evaluate-defvar): Bind *package* to *buffer-package*.
+ (with-trapping-compilation-notes): Add a dummy argument for better
+ indentation.
+ (measure-time-intervall, call-with-compilation-hooks): Measure
+ compilation time.
+ (frame-locals): Use di::debug-function-debug-variables instead of
+ di:ambiguous-debug-variables. Don't access non-valid variables.
+
+ * slime.el
+ (slime-display-message-or-view): Delete old multi-line windows.
+ (slime-read-package-name): Added an optional initial-value
+ argument. slime-pid: New variable.
+ (slime-init-dispatcher): Initialize slime-pid.
+ (slime-send-sigint): Use slime-pid instead of inferior-lisp-proc.
+ (slime-eval): Accept debug-condition messages.
+ (slime-output-buffer): Turn slime-mode on.
+ (slime-switch-to-output-buffer): New command. Bound to C-c C-z.
+ (slime-show-note-counts): Display compilation time.
+ (slime-untrace-all, slime-set-package, slime-set-default-directory
+ slime-sync-package-and-default-directory): New commands.
+ (slime-princ-locals): Don't access non-valid variables. This may
+ cause segfaults and severely confuse CMUCL.
+ (slime-define-keys): New macro.
+
+2003-09-28 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (create-swank-server): Bind the listen-socket on the
+ loopback interface by default, so that remote machines can't
+ connect to the Swank server.
+
+2003-09-27 Luke Gorrie <luke(a)bluetail.com>
+
+ * swank.lisp (with-trapping-compilation-notes): New macro for
+ bindings the handlers to record compiler notes. Now being used in
+ `compile-string', which I had broken when removing the compilation
+ hook.
+
+ * slime.el (slime-function-called-at-point): Rewritten to work
+ better. Now considers "((foo ..." _not_ to be a function call to
+ foo because of the double ('s - this will keep it from misfiring
+ in e.g. LET bindings.
+ (def-slime-test): All tests now being with (slime-sync). This
+ fixes some accidental/bogus test failures.
+
+ * swank.lisp (handle-notification-condition): Rewrote
+ compiler-note collection. Now it uses lower-level condition
+ handlers instead of c:*compiler-notification-function*. This way
+ the error messages are tailored to omit redundant information,
+ like the filename and original source text (which are displayed
+ and highlighted in Emacs already). Much nicer.
+ (sort-contexts-by-source-path): Now sorting xref results by
+ lexical source-path order, so that you're always jumping in the
+ same direction.
+ (*debug-definition-finding*): New variable. You can set this to
+ true if you want to be popped into the debugger when M-. fails to
+ find a definition (for debugging the
+ definition-finding). Otherwise it reports the error to Emacs as a
+ message, like "Error: SETQ is a special form."
+
+ * slime.el (slime-fetch-features-list): New command to fetch the
+ *FEATURES* list from Lisp and store it away. This is done
+ automatically upon connection, but can also be called manually to
+ update.
+ (slime-forward-reader-conditional): Now does the right things with
+ reader-conditionals (#+ and #-) based on the Lisp features.
+
+2003-09-26 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (sldb-setup): Setting `truncate-lines' to t in the
+ debug buffer. I like having the backtrace take strictly one line
+ per frame, since otherwise a few ugly arguments (e.g. streams) can
+ chew up a lot of space. (Can make this a configurable on request
+ if tastes differ :-)
+
+ * swank.lisp: Did a little defensive programming so that asking
+ for the definition of an unbound function will return nil to Emacs
+ instead of entering the debugger.
+ (format-frame-for-emacs): Binding *PRETTY-PRINT* to nil when
+ formatting frames (due to truncate-lines change above).
+
+2003-09-24 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp:
+ Support for stream redirection.
+ slime-output-stream: New structure.
+ (slime-out-misc): New function.
+ *slime-output*: New variable.
+ (read-from-emacs): Redirect output to *slime-output*.
+ (read-form): Bind *package* inside the standard-io-syntax macro.
+ (eval-string): Read the string with read-form.
+ (completions): Support for keyword completion.
+
+ * slime.el (slime-process-available-input, slime-eval): Rewritten
+ once again. Don't use unwind-protect anymore. Didn't work
+ properly when the Lisp side aborted due to too many debug
+ levels. "Continuing" from the Emacs debugger aborts one level on
+ the Lisp side. "Quitting" from the Emacs debugger quits the Lisp
+ side too. Increase stack sizes before entering the recursive edit.
+ (slime-eval-async-state, slime-eval, sldb-state): Support for stream
+ output.
+ slime-last-output-start: New variable.
+ (slime-output-buffer, slime-output-buffer-position,
+ slime-insert-transcript-delimiter, slime-show-last-output,
+ slime-output-string): New functions.
+ (slime-show-evaluation-result,
+ slime-show-evaluation-result-continuation): Use them.
+ (slime-use-inf-lisp-p, slime-insert-transcript-delimiter,
+ slime-inferior-lisp-marker-position,
+ slime-inferior-lisp-show-last-output): Deleted.
+ (slime-use-tty-debugger, slime-debugger-hook,
+ slime-enter-tty-debugger, slime-tty-debugger-state): Deleted. Removed
+ tty debugger support.
+ (def-sldb-invoke-restart): Renamed.
+ (define-sldb-invoke-restart-key, define-sldb-invoke-restart-keys):
+ Version without eval.
+ (defun-if-undefined): New macro.
+ Many indentation fixes.
+
+2003-09-23 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * swank.lisp (completions):
+ Moved most of the completion code to Lisp.
+ (string-prefix-p): Be case insensitive.
+
+ * slime.el:
+ Make sure define-minor-mode is defined before we use it.
+ (slime-completing-read-internal, slime-completing-read-symbol-name,
+ slime-read-from-minibuffer, slime-completions, slime-complete-symbol):
+ Support for reading symbols and expressions with completion.
+ (slime-read-symbol-name): New function.
+ (slime-read-symbol): Use it.
+ (slime-read-package-name): Case insensitive completion.
+
+ (slime-edit-symbol-fdefinition, slime-edit-fdefinition): Rename
+ slime-edit-symbol-fdefinition to slime-edit-fdefinition.
+
+2003-09-23 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-show-xrefs): Improved the xrefs buffer, now
+ using a custom minor mode.
+ (slime-next-location): This function goes to the next "something"
+ by funcall'ing slime-next-location-function. Currently that
+ variable is set by xref commands like who-calls to go to the next
+ matching reference. In future it can also be used to go to the
+ next function definition for a generic-function-understanding
+ version of edit-fdefinition. Bound to C-M-. and C-c C-SPC, until
+ we see which binding is better.
+
+2003-09-22 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-symbol-at-point): Now returns a symbol, as the
+ name suggests.
+ (slime-symbol-name-at-point): This one returns a string.
+ (slime-read-symbol): New function for taking the symbol at point,
+ or prompting if there isn't one.
+ (slime-edit-fdefinition): Now uses looks up the symbol at point,
+ not the function being called at point.
+
+ * swank.lisp (who-calls, who-references, who-binds, who-sets,
+ who-macroexpands): New function.
+ (present-symbol-before-p): Use `*buffer-package*' when checking
+ accessibility of symbols.
+
+ * slime.el (slime-restore-window-configuration): New command to
+ put the Emacs window configuration back the way it was before
+ SLIME last changed it.
+ (slime-who-calls, etc): Very basic WHO-{CALLS,..} support. Not
+ finished, wrestling around trying to make `view-mode' or
+ `help-mode' help me (I just want to hijack RET and C-m). Bound to
+ "C-c C-w ...".
+
+2003-09-21 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el: Rearranged the `outline-mode' structure slightly.
+ (slime-check-connected): Using new function to give a helpful
+ error message if you try to use commands before establishing a
+ connection to CMUCL.
+ (sldb-mode): Keys 0-9 are now shortcuts to invoke restarts.
+
+ * README, swank.el: Updated commentary.
+
+2003-09-20 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-choose-overlay-region): Tweaked overlay
+ placement.
+
+ * swank.lisp (handle-notification): Skipping null
+ notifications. For some reason CMUCL occasionally calls us with
+ NIL as each argument.
+
+2003-09-19 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-connect): Propose default values when called
+ interactively.
+ (slime-process-available-input): If possible, use while rather than
+ recursion.
+ (slime-compilation-finished-continuation): New function.
+ (slime-compile-file, slime-compile-defun): Use it.
+ (slime-forward-source-path): Id an error is encounter move back to the
+ last valid point.
+ (slime-eval-region): Use append COND. Send the entire string to the
+ Lisp side and read&evaluate it there.
+ (slime-eval-buffer): New function.
+ (sldb-sugar-move, sldb-details-up, sldb-details-down): New functions.
+
+ * swank.lisp (interactive-eval-region): New function.
+ (re-evaluate-defvar): New function.
+ (compile-defun): Install handler for compiler-errors.
+ (function-first-code-location): Simplified.
+
+2003-09-17 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-apropos-all): New command, bound to C-c M-a.
+ (slime-eval): Simplified.
+ (swank:arglist-string): Send a string and not a symbol. It easier
+ to package related thins in CL.
+ (slime-edit-symbol-fdefinition): Prompt when called with
+ prefix-argument.
+ (slime-eval-region): New function.
+ (slime-load-file): New function.
+ (slime-show-description): Set slime minor mode in Help buffer.
+
+ * swank.lisp: (read-string, from-string): Renamed read-string to
+ from-string.
+ (to-string) New function.
+ (arglist-string): Catch reader errors.
+ (sldb-loop): Also bind *readstrable*.
+
+
+2003-09-16 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el (slime-toggle-trace-fdefinition): New command.
+ (slime-symbol-at-point, slime-sexp-at-point): New utility functions.
+ (slime-edit-symbol-fdefinition): Similar to slime-edit-fdefinition but
+ uses swank:function-source-location-for-emacs.
+ (slime-goto-source-location): New function.
+ (sldb-show-source): Use it.
+ (slime-read-package-name): Completing read for package names.
+ (slime-apropos): Use it.
+
+ * swank.lisp (function-source-location,
+ function-source-location-for-emacs): New functions to extract
+ source locations from compiled code. For struct-accessors we try
+ to find the source location of the corresponding constructor.
+ (list-all-package-names): New function.
+ (toggle-trace-fdefinition, tracedp): New functions.
+
+2003-09-15 Helmut Eller <e9626484(a)stud3.tuwien.ac.at>
+
+ * slime.el: Moved many CL fragments from slime.el to swank.lisp.
+ (slime-compile-file, slime-compile-defun, slime-goto-location):
+ Compiler notes are now represented with a property list. To find
+ the source expression first move to the file offset of the
+ top-level form and then use the source path to find the
+ expression. This should avoid many reader issues. For
+ compile-defun store the start position of the top-level expression
+ from the buffer in the compiler notes and use that to locate error
+ messages. Add error overlays for notes without context to the
+ first available expression.
+
+ * swank.lisp: Moved many CL fragments from slime.el to swank.lisp.
+ (defslimefun): New macro.
+
+2003-09-15 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-setup-command-hooks): Removed post-command-hook
+ that was used for cleaning up input that was unprocessed due to an
+ error breaking out of the process filter. This is now handled by
+ an `unwind-protect' in the filter.
+
+ * swank.lisp (apropos-list-for-emacs): Hacked the apropos listing
+ to accept more options and to specially sort results.
+
+ * slime.el (slime-net-send): Added newlines to messages over the
+ wire. This makes the protocol nicely readable in Ethereal.
+ (slime-sync): New function for blocking until asynchronous
+ requests are complete.
+ (slime-apropos): Hacked the apropos command: by default, only
+ external symbols are shown. With a prefix argument you have the
+ option to include internal symbols and to specify a package.
+ (slime-run-tests): Extended the test suite. Use `M-x
+ slime-run-tests' to run it.
+
+2003-09-14 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el, swank.lisp: Added the debugger written by Helmut.
+
+ * cmucl-wire.el: Removed. The WIRE communication protocol has been
+ replaced by a simple custom TCP protocol based on READ/PRIN1 to
+ send sexps as ascii text. This simplifies the code, makes the
+ protocol nicely debugable with ethereal, and should ease porting
+ to other Lisps. Incremented TCP port number to 4005 in honor of
+ the new protocol.
+
+ In addition, Lisp now always uses *print-case* of :DOWNCASE when
+ preparing sexps for Emacs. This is in reaction to a bug with Emacs
+ reading the empty list as `NIL' instead of `nil'.
+
+ * slime.el (slime-net-connect): The Emacs end of the new
+ communication protocol.
+
+ * swank.lisp (create-swank-server): The Lisp end of the new
+ communication protocol.
+
+2003-09-11 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-mode): Added Helmut's commands to the mode
+ description.
+ (slime-show-apropos): Setting `truncate-lines' to t in apropos
+ listings, to avoid line-wrapping on overly long descriptions.
+ (slime-run-tests): Added the beginnings of an automated test
+ suite. (This is most useful for testing cross-Emacsen
+ compatibility before releases.)
+
+ * swank.lisp (symbol-external-p): Put back this function which was
+ lost in a merge.
+
+2003-09-10 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el, cmucl-wire.el, swank.lisp: Large patch from Helmut
+ Eller. Includes: apropos, describe, compile-defun, fully
+ asynchronous continuation-based wire interface, interactive
+ evaluation, and more. Very nice :-)
+
+2003-09-08 Luke Gorrie <luke(a)bluetail.com>
+
+ * cmucl-wire.el (wire-symbol-name, wire-symbol-package): Fixed to
+ handle internal references (pkg::name).
+
+ * slime.el (slime-swank-connection-retries): Increased default
+ number of connection retries from 5 to ten.
+
+ * swank.lisp (find-fdefinition): Support for finding
+ function/macro definitions for Emacs.
+
+ * slime.el: Indentation "cleanups": somehow I was using
+ `common-lisp-indent-function' for Emacs Lisp code previously.
+ (slime-edit-fdefinition): Added M-. (edit definition) and M-, (pop
+ definition stack) commands. Definitions are found in much the same
+ way Hemlock does it. The user-interface is not the same as TAGS,
+ because I like this one better. We can add TAGS-compatibility as
+ an optional feature in future.
+
+2003-09-04 Luke Gorrie <luke(a)bluetail.com>
+
+ * slime.el (slime-completions): Now supports completing
+ package-internal symbols with "pkg::prefix" syntax.
+
+ * Everything: imported slime-0.2 sources.
+
+;; Local Variables:
+;; coding: latin-1
+;; End:
+
+This file has been placed in the public domain.
Added: branches/bos/thirdparty/emacs/slime/HACKING
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/HACKING Fri Jan 18 06:05:59 2008
@@ -0,0 +1,136 @@
+* The SLIME Hacker's Handbook -*- outline -*-
+
+* Lisp code file structure
+
+The Lisp code is organised into these files:
+
+ swank-backend.lisp:
+ Definition of the interface to non-portable features.
+ Stand-alone.
+
+ swank-<cmucl|...>.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.
+
+* ChangeLog
+
+For each change we make an entry in the ChangeLog file. This is
+typically done using the command `add-change-log-entry-other-window'
+(C-x 4 a). The message can be automatically extracted from the
+ChangeLog to use in a CVS commit message by pressing C-c C-a in a
+vc-mode or pcl-cvs commit buffer.
+
+ChangeLog diffs are automatically sent to the slime-devel mailing list
+each day as a sort of digest summary of the slime-cvs list.
+
+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'
+and `Change Logs and VC' nodes of the Emacs manual:
+ http://www.gnu.org/software/emacs/manual/html_node/emacs_333.html#SEC333
+ http://www.gnu.org/software/emacs/manual/html_node/emacs_156.html#SEC156
+
+* Sending Patches
+
+If you would like to send us improvements you can create a patch with
+C-x v = in the buffer or manually with 'cvs diff -u'. It's helpful if
+you also include a ChangeLog entry describing your change.
+
+* Test Suite
+
+The Elisp code includes a command `slime-run-tests' to run a test
+suite. This can give a pretty good sanity-check for your changes.
+
+Some backends do not pass the full test suite because of missing
+features. In these cases the test suite is still useful to ensure that
+changes don't introduce new errors. CMUCL historically passes the full
+test suite so it makes a good sanity check for fundamental changes
+(e.g. to the protocol).
+
+Running the test suite, adding new cases, and increasing the number of
+cases that backends support are all very good for karma.
+
+
+* Source code layout
+
+We use a special source file layout to take advantage of some fancy
+Emacs features: outline-mode and "narrowing".
+
+** Outline structure
+
+Our source files have a hierarchical structure using comments like
+these:
+
+ ;;;; Heading
+ ;;;;; Subheading
+ ... etc
+
+We do this as a nice way to structure the program. We try to keep each
+(sub)section small enough to fit in your head: typically around 50-200
+lines of code each. Each section usually begins with a brief
+introduction, followed by its highest-level functions, followed by
+their subroutines. This is a pleasing shape for a source file to have.
+
+Of course the comments mean something to Emacs too. One handy usage is
+to bring up a hyperlinked "table of contents" for the source file
+using this command:
+
+ (defun show-outline-structure ()
+ "Show the outline-mode structure of the current buffer."
+ (interactive)
+ (occur (concat "^" outline-regexp)))
+
+Another is to use `outline-minor-mode' to fold away certain parts of
+the buffer. See the `Outline Mode' section of the Emacs manual for
+details about that.
+
+(This file is also formatted for outline mode. If you're reading in
+Emacs you can play around e.g. by pressing `C-c C-d' right now.)
+
+** Pagebreak characters (^L)
+
+We partition source files into chunks using pagebreak characters. Each
+chunk is a substantial piece of code that can be considered in
+isolation, that could perhaps be a separate source file if we were
+fanatical about small source files (rather than big ones!)
+
+The page breaks usually go in the same place as top-level outline-mode
+headings, but they don't have to. They're flexible.
+
+In the old days, when slime.el was less than 100 pages long, these
+page breaks were helpful when printing it out to read. Now they're
+useful for something else: narrowing.
+
+You can use `C-x n p' (narrow-to-page) to "zoom in" on a
+pagebreak-delimited section of the file as if it were a separate
+buffer in itself. You can then use `C-x n w' (widen) to "zoom out" and
+see the whole file again. This is tremendously helpful for focusing
+your attention on one part of the program as if it were its own file.
+
+(This file contains some page break characters. If you're reading in
+Emacs you can press `C-x n p' to narrow to this page, and then later
+`C-x n w' to make the whole buffer visible again.)
+
+
+* Coding style
+
+We like the fact that each function in SLIME will fit on a single
+screen (80x20), and would like to preserve this property! Beyond that
+we're not dogmatic :-)
+
+In early discussions we all made happy noises about the advice in
+Norvig and Pitman's _Tutorial on Good Lisp Programming Style_:
+ http://www.norvig.com/luv-slides.ps
+
+For Emacs Lisp, we try to follow the _Tips and Conventions_ in
+Appendix D of the GNU Emacs Lisp Reference Manual (see Info file
+`elisp', node `Tips').
+
+Remember that to rewrite a program better is the sincerest form of
+code appreciation. When you can see a way to rewrite a part of SLIME
+better, please do so!
Added: branches/bos/thirdparty/emacs/slime/NEWS
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/NEWS Fri Jan 18 06:05:59 2008
@@ -0,0 +1,159 @@
+* SLIME News -*- outline -*-
+
+* 3.0 (not released yet)
+
+** Removed Features
+Some of the more esoteric features, like presentations or fuzzy
+completion, are no longer enabled by default. A new directory
+"contrib/" contains the code for these packages. To use them, you
+must make some changes to your ~/.emacs. For details see, section
+"Contributed Packages" in the manual.
+
+** Stepper
+Juho Snellman implemented stepping commands for SBCL.
+
+** Completions
+SLIME can now complete keywords and character names (like #\newline).
+
+* 2.0 (April 2006)
+
+** In-place macro expansion
+Marco Baringer wrote a new minor mode to incrementally expand macros.
+
+** Improved arglist display
+SLIME now recognizes `make-instance' calls and displays the correct
+arglist if the classname is present. Similarly, for `defmethod' forms
+SLIME displays the arguments of the generic function.
+
+** Persistent REPL history
+SLIME now saves the command history from REPL buffers in a file and
+reloads it for newly created REPL buffers.
+
+** Scieneer Common Lisp
+Douglas Crosher added support for Scieneer Common Lisp.
+
+** SBCL
+Various improvements to make SLIME work well with current SBCL versions.
+
+** Corman Common Lisp
+Espen Wiborg added support for Corman Common Lisp.
+
+** Presentations
+A new feature which associates objects in Lisp with their textual
+represetation in Emacs. The text is clickable and operations on the
+associated object can be invoked from a pop-up menu.
+
+** Security
+SLIME has now a simple authentication mechanism: if the file
+~/.slime-secret exists we verify that Emacs and Lisp can access it.
+Since both parties have access to the same file system, we assume that
+we can trust each other.
+
+* 1.2 (March 2005)
+
+** New inspector
+The lisp side now returns a specially formated list of "things" to
+format which are then passed to emacs and rendered in the inspector
+buffer. Things can be either text, recursivly inspectable values, or
+functions to call. The new inspector has much better support CLOS
+objects and methods.
+
+** Unicode
+It's now possible to send non-ascii characters to Emacs, if the
+communication channel is configured properly. See the variable
+`slime-net-coding-system'.
+
+** Arglist lookup while debugging
+Previously, arglist lookup was disabled while debugging. This
+restriction was removed.
+
+** Extended tracing command
+It's now possible to trace individual a single methods or all methods
+of a generic function. Also tracing can be restricted to situations
+in which the traced function is called from a specific function.
+
+** M-x slime-browse-classes
+A simple class browser was added.
+
+** FASL files
+The fasl files for different Lisp/OS/hardware combinations are now
+placed in different directories.
+
+** Many other small improvements and bugfixes
+
+* 1.0 (September 2004)
+
+** slime-interrupt
+The default key binding for slime-interrupt is now C-c C-b.
+
+** sldb-inspect-condition
+In SLDB 'C' is now bound to sldb-inspect-condition.
+
+** More Menus
+SLDB and the REPL have now pull-down menus.
+
+** Global debugger hook.
+A new configurable *global-debugger* to control whether
+swank-debugger-hook should be installed globally is available. True by
+default.
+
+** When you call sldb-eval-in-frame with a prefix argument, the result is
+now inserted in the REPL buffer.
+
+** Compile function
+For Allegro M-. works now for functions compiled with C-c C-c.
+
+** slime-edit-definition
+Better support for Allegro: works now for different type of
+definitions not only. So M-. now works for e.g. classes in Allegro.
+
+** SBCL 0.8.13
+SBCL 0.8.12 is no longer supported. Support for 0.8.12 was broken for
+for some time now.
+
+* 1.0 beta (August 2004)
+
+** autodoc global variables
+The slime-autodoc-mode will now automatically show the value of a
+global variable at point.
+
+** Customize group
+The customize group is expanded and better-organised.
+
+** slime-interactive-eval
+Interactive-eval commands now print their results to the REPL when
+given a prefix argument.
+
+** slime-conservative-indentation
+New Elisp variable. Non-nil means that we exclude def* and with-* from
+indentation-learning. The default is t.
+
+** (slime-setup)
+New function to streamline setup in ~/.emacs
+
+** Modeline package
+The package name in the modeline is now updated on an idle timer. The
+message should now be more meaningful when moving around in files
+containing multiple IN-PACKAGE forms.
+
+** XREF bugfix
+The XREF commands did not find symbols in the right package.
+
+** REPL prompt
+The package name in the REPL's prompt is now abbreviated to the last
+`.'-delimited token, e.g. MY.COMPANY.PACKAGE would be PACKAGE. This
+can be disabled by setting SWANK::*AUTO-ABBREVIATE-DOTTED-PACKAGES* to
+NIL.
+
+** CMUCL source cache
+The source cache is now populated on `first-change-hook'. This makes
+M-. work accurately in more file modification scenarios.
+
+** SBCL compiler errors
+Detect compiler errors and make some noise. Previously certain
+problems (e.g. reader-errors) could slip by quietly.
+
+* 1.0 alpha (June 2004)
+
+The first preview release of SLIME.
+
Added: branches/bos/thirdparty/emacs/slime/PROBLEMS
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/PROBLEMS Fri Jan 18 06:05:59 2008
@@ -0,0 +1,95 @@
+Known problems with SLIME -*- outline -*-
+
+* Common to all backends
+
+** Caution: network security
+The `M-x slime' command has Lisp listen on a TCP socket and wait for
+Emacs to connect, which typically takes on the order of one second. If
+someone else were to connect to this socket then they could use the
+SLIME protocol to control the Lisp process.
+
+The listen socket is bound on the loopback interface in all Lisps that
+support this. This way remote hosts are unable to connect.
+
+** READ-CHAR-NO-HANG is broken
+
+READ-CHAR-NO-HANG doesn't work properly for slime-input-streams. Due
+to the way we request input from Emacs it's not possible to repeatedly
+poll for input. To get any input you have to call READ-CHAR (or a
+function which calls READ-CHAR).
+
+* Backend-specific problems
+
+** CMUCL
+
+The default communication style :SIGIO is reportedly unreliable with
+certain libraries (like libSDL) and certain platforms (like Solaris on
+Sparc). It generally works very well on x86 so it remains the default.
+
+** SBCL
+
+The latest released version of SBCL at the time of packaging should
+work. Older or newer SBCLs may or may not work. Do not use
+multithreading with unpatched 2.4 Linux kernels. There are also
+problems with kernel versions 2.6.5 - 2.6.10.
+
+The (v)iew-source command in the debugger can only locate exact source
+forms for code compiled at (debug 2) or higher. The default level is
+lower and SBCL itself is compiled at a lower setting. Thus only
+defun-granularity is available with default policies.
+
+The XREF commands are not implemented.
+
+** OpenMCL
+
+We support OpenMCL 0.14.3.
+
+The XREF commands are not available.
+
+** LispWorks
+
+On Windows, SLIME hangs when calling foreign functions or certain
+other functions. The reason for this problem is unknown.
+
+We only support latin1 encoding. (Unicode wouldn't be hard to add.)
+
+** Allegro CL
+
+Interrupting Allegro with C-c C-b can be slow. This is caused by the
+a relatively large process-quantum: 2 seconds by default. Allegro
+responds much faster if mp:*default-process-quantum* is set to 0.1.
+
+** CLISP
+
+We require version 2.33.2 or higher. We also require socket support, so
+you may have to start CLISP with "clisp -K full".
+
+Under Windows, interrupting (with C-c C-b) doesn't work. Emacs sends
+a SIGINT signal, but the signal is either ignored or CLISP exits
+immediately.
+
+Function arguments and local variables aren't displayed properly in
+the backtrace. Changes to CLISP's C code are needed to fix this
+problem. Interpreted code is usually easer to debug.
+
+M-. (find-definition) only works if the fasl file is in the same
+directory as the source file.
+
+The arglist doesn't include the proper names only "fake symbols" like
+`arg1'.
+
+** Armed Bear Common Lisp
+
+The ABCL support is still new and experimental.
+
+** Corman Common Lisp
+
+We require version 2.51 or higher, with several patches (available at
+http://www.grumblesmurf.org/lisp/corman-patches).
+
+The only communication style currently supported is NIL.
+
+Interrupting (with C-c C-b) doesn't work.
+
+The tracing, stepping and XREF commands are not implemented along with
+some debugger functionality.
Added: branches/bos/thirdparty/emacs/slime/README
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/README Fri Jan 18 06:05:59 2008
@@ -0,0 +1,41 @@
+Overview.
+----------------------------------------
+
+ SLIME is the Superior Lisp Interaction Mode for Emacs. It is
+ implemented in two main parts: the Emacs Lisp side (slime.el), and
+ the support library for the Common Lisp (swank.lisp and swank-*.lisp)
+
+ For a real description, see the manual in doc/
+
+Quick setup instructions
+------------------------
+
+ Add this to your ~/.emacs file and fill in the appropriate filenames:
+
+ (add-to-list 'load-path "~/hacking/lisp/slime/") ; your SLIME directory
+ (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") ; your Lisp system
+ (require 'slime)
+ (slime-setup)
+
+ Make sure your `inferior-lisp-program' is set to a compatible
+ version of Lisp.
+
+ Use `M-x' slime to fire up and connect to an inferior Lisp.
+ SLIME will now automatically be available in your Lisp source
+ buffers.
+
+Licence.
+----------------------------------------
+
+ SLIME is free software. All files, unless explicitly stated
+ otherwise, are public domain.
+
+Contact.
+----------------------------------------
+
+ Questions and comments are best directed to the mailing list:
+ http://common-lisp.net/mailman/listinfo/slime-devel
+
+ The mailing list archive is also available on Gmane:
+ http://news.gmane.org/gmane.lisp.slime.devel
+
Added: branches/bos/thirdparty/emacs/slime/contrib/CVS/Entries
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/CVS/Entries Fri Jan 18 06:05:59 2008
@@ -0,0 +1,31 @@
+/ChangeLog/1.78/Fri Jan 11 13:06:45 2008//
+/README/1.3/Fri Sep 28 13:05:44 2007//
+/bridge.el/1.1/Wed Sep 19 11:47:03 2007//
+/inferior-slime.el/1.2/Mon Sep 10 21:44:48 2007//
+/slime-asdf.el/1.3/Fri Sep 21 12:44:13 2007//
+/slime-autodoc.el/1.5/Mon Oct 1 13:37:10 2007//
+/slime-banner.el/1.4/Thu Sep 20 14:55:53 2007//
+/slime-c-p-c.el/1.8/Thu Sep 20 14:55:53 2007//
+/slime-editing-commands.el/1.6/Thu Jan 10 15:32:08 2008//
+/slime-fancy-inspector.el/1.2/Thu Sep 20 14:55:53 2007//
+/slime-fancy.el/1.4/Fri Sep 28 13:05:35 2007//
+/slime-fuzzy.el/1.6/Thu Jan 10 00:39:19 2008//
+/slime-highlight-edits.el/1.3/Thu Sep 20 14:55:53 2007//
+/slime-parse.el/1.10/Thu Jan 10 20:00:04 2008//
+/slime-presentation-streams.el/1.2/Tue Aug 28 08:25:12 2007//
+/slime-presentations.el/1.11/Fri Jan 11 13:06:35 2008//
+/slime-references.el/1.4/Thu Sep 20 14:55:53 2007//
+/slime-scheme.el/1.1/Wed Jan 9 18:30:26 2008//
+/slime-scratch.el/1.4/Thu Sep 20 14:55:53 2007//
+/slime-tramp.el/1.2/Tue Sep 4 10:18:44 2007//
+/slime-typeout-frame.el/1.5/Mon Oct 1 11:50:06 2007//
+/slime-xref-browser.el/1.1/Fri Aug 24 14:47:11 2007//
+/swank-arglists.lisp/1.18/Thu Jan 10 20:00:17 2008//
+/swank-asdf.lisp/1.1/Tue Sep 4 10:32:07 2007//
+/swank-c-p-c.lisp/1.2/Wed Sep 5 19:35:35 2007//
+/swank-fancy-inspector.lisp/1.5/Tue Nov 20 21:29:41 2007//
+/swank-fuzzy.lisp/1.7/Thu Jan 10 00:39:37 2008//
+/swank-listener-hooks.lisp/1.1/Tue Aug 28 13:53:02 2007//
+/swank-presentation-streams.lisp/1.4/Tue Aug 28 16:26:32 2007//
+/swank-presentations.lisp/1.4/Tue Sep 4 09:49:10 2007//
+D
Added: branches/bos/thirdparty/emacs/slime/contrib/CVS/Repository
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/CVS/Repository Fri Jan 18 06:05:59 2008
@@ -0,0 +1 @@
+slime/contrib
Added: branches/bos/thirdparty/emacs/slime/contrib/CVS/Root
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/CVS/Root Fri Jan 18 06:05:59 2008
@@ -0,0 +1 @@
+:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot
Added: branches/bos/thirdparty/emacs/slime/contrib/CVS/Template
==============================================================================
Added: branches/bos/thirdparty/emacs/slime/contrib/ChangeLog
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/ChangeLog Fri Jan 18 06:05:59 2008
@@ -0,0 +1,646 @@
+2008-01-11 Stelian Ionescu <sionescu(a)common-lisp.net>
+
+ * slime-presentations.el
+ (slime-copy-or-inspect-presentation-at-mouse): Call
+ slime-copy-presentation-at-mouse-to-repl rather than
+ slime-copy-presentation-at-mouse.
+
+2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-parse.el (slime-make-form-spec-from-string): Correctly
+ handle quoted things and other non-proper "(...)" forms.
+
+ * swank-arglist.lisp (read-form-spec): Added assertion against
+ receiving junk form specs from Emacs.
+
+2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-editing-commands.el (slime-close-all-parens-in-sexp): Use
+ new portability function `slime-delete-and-extract-region'.
+
+2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-parse.lisp (slime-incomplete-form-at-point): Hopefully
+ better fix than before.
+
+2008-01-10 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Add keyboard commands (starting with C-c C-v) and a top-level menu
+ for presentation-related commands. Add a command (C-c C-v M-o) to
+ forget all objects associated with presentations, without
+ clearing the REPL buffer.
+
+ * slime-presentations.el
+ (slime-presentation-around-or-before-point-or-error): New
+ function.
+ (slime-inspect-presentation): New function, factored out from
+ slime-inspect-presentation-at-mouse.
+ (slime-inspect-presentation-at-mouse): Use it here.
+ (slime-inspect-presentation-at-point): New command.
+ (slime-copy-presentation-to-repl): New function, factored out
+ from slime-copy-presentation-at-mouse.
+ (slime-copy-presentation-at-mouse-to-repl): Renamed from
+ slime-copy-presentation-at-mouse; use the new function
+ slime-copy-presentation-to-repl.
+ (slime-copy-presentation-at-point-to-repl): New command.
+ (slime-copy-presentation-to-kill-ring): New function, factored
+ out from slime-copy-presentation-at-mouse-to-kill-ring.
+ (slime-copy-presentation-at-point-to-kill-ring): New command.
+ (slime-describe-presentation): New function, factored out from
+ slime-describe-presentation-at-mouse.
+ (slime-describe-presentation-at-mouse): Use it here.
+ (slime-describe-presentation-at-point): New command.
+ (slime-pretty-print-presentation): New function, factored out
+ from slime-pretty-print-presentation-at-mouse.
+ (slime-pretty-print-presentation-at-mouse): Use it here.
+ (slime-pretty-print-presentation-at-point): New command.
+ (slime-mark-presentation): New command.
+ (slime-previous-presentation, slime-next-presentation): New
+ commands.
+ (slime-presentation-command-map, slime-presentation-bindings):
+ New variables.
+ (slime-presentation-init-keymaps): New function.
+ (slime-presentation-around-or-before-point-p): New function.
+ (slime-presentation-easy-menu): New variable.
+ (slime-presentation-add-easy-menu): New function.
+ (slime-clear-presentations): Make interactive, remove
+ presentation markup from all presentations in the REPL buffer.
+ (slime-presentations-init): Call slime-presentation-init-keymaps
+ and slime-presentation-add-easy-menu.
+
+2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-parse.lisp (slime-incomplete-form-at-point): Take the
+ arglist index the user's point is located at correctly into
+ account. Previously `C-c C-s' on `(defun |foo' would have inserted
+ `args body...)', now it inserts `name args body...)'
+
+2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglists.lisp (read-form-spec): Changed "cons" clause to
+ "list" clause in etypecase. Fix for error on arglist display on
+ `(declare (ftype (|)))', | being point.
+
+2008-01-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-fuzzy.el (slime-fuzzy-completion-time-limit-in-msec):
+ Update docstring: Its value isn't rounded to nearest second, but
+ is really interpreted as msecs.
+
+ * swank-fuzzy.el: Updated some comments.
+ (fuzzy-generate-matchings): Sort package matchings before
+ traversal, such that they're traversed in the order of their
+ score. (Important when time limit exhausts during traversal.)
+
+2008-01-09 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Restore support for Scheme programs that was removed from core
+ SLIME on 2007-09-19, as a "slime-scheme" contrib.
+
+ * slime-scheme.el: New file.
+
+2007-12-30 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglists.lisp: Fix for `(cerror "FOO" 'type-error ...)'
+
+ (*arglist-dummy*): Removed.
+ (arglist-dummy): New structure. Wrapper around whatever could not
+ be reliably read. The clue is that its printing function does only
+ print the object this structure contains.
+ (read-conversatively-for-autodoc): Return such a structure if
+ conversative reading fails.
+
+2007-11-27 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglists.lisp (arglist-dispatch 'defmethod): Use
+ VALID-FUNCTION-NAME-P. Fixes error on certain `(defmethod (setf ...))'
+ forms.
+
+2007-11-27 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglists.lisp (print-arglist): Print initforms in &optional and
+ &key lambda list specifiers as if by PRIN1 instead of PRINC.
+ Reported by Michael Weber.
+
+2007-11-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-fuzzy.el: Use slime-require instead of a connected-hook.
+
+2007-11-20 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-fancy-inspector.lisp (inspect-for-emacs function t): Don't
+ specialize the second argument, so that backend methods take
+ precedence. Reported by Maciej Katafiasz.
+
+2007-10-24 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglist.lisp (decode-arglist): Fix incompatibility with
+ ACL's modern reader mode. Thanks to Andreas Fuchs for stumbling
+ over this.
+
+2007-10-22 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglist.lisp (read-softly): Renamed to
+ READ-SOFTLY-FROM-STRING and moved to `swank.lisp'.
+ (unintern-in-home-package): Moved to `swank.lisp'.
+
+2007-10-01 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-autdoc.el (slime-autodoc-message-ok-p): Don't display an
+ arglist when the minibuffer is active.
+
+2007-10-01 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-typeout-frame.el: Messages in the typeout frame were too
+ easily overwritten by `slime-autodoc'. Fix that.
+ Reported by Geoff Wozniak.
+
+ (slime-typeout-message-aux): Split out from `slime-typeout-message'.
+ (slime-typeout-message): Wrapper around it. Additionally disable
+ the autodoc timer temporarily.
+
+2007-09-30 Geoff Wozniak <geoff(a)wozniak.ca>
+
+ * slime-typeout-frame.el (slime-typeout-frame-init): Fix quoted
+ FUNCTION forms in literal.
+
+2007-09-28 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * README: Updated.
+
+ * slime-fancy.el: `slime-highlighting-edits' is not enabled by
+ default anymore, as its functionality is controversial, and it's
+ easier to explicitly enable it than to disable it once it got
+ globally activated. Better to be conservative.
+
+ * slime-fancy.el: Not only load, but also enable `slime-scratch'.
+
+2007-09-21 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-asdf.el (slime-asdf-init, slime-asdf-unload): Fix typos.
+ Reported by Ariel Badichi.
+
+2007-09-20 Helmut Eller <heller(a)common-lisp.net>
+
+ Separate loading from initialization for many contribs.
+
+ * slime-asdf.el
+ * slime-autodoc.el
+ * slime-banner.el
+ * slime-c-p-c.el
+ * slime-editing-commands.el
+ * slime-fancy-inspector.el
+ * slime-fuzzy.el
+ * slime-highlight-edits.el
+ * slime-presentations.el
+ * slime-references.el
+ * slime-scratch.el
+ * slime-typeout-frame.el
+ * swank-fancy-inspector.lisp
+
+ * slime-fancy.el: As an exception, call the respective init
+ function when loading.
+
+2007-09-19 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-c-p-c.el (slime-complete-symbol*-fancy): Move defcustom
+ from slime.el to contrib/slime-c-p-c.el.
+
+2007-09-16 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-fuzzy.lisp: Fix regression that would not allow to fuzzy
+ complete on inputs without package qualifier like "app".
+ Reported by David J. Neu.
+
+ (%make-duplicate-symbols-filter): Return complement.
+ (fuzzy-find-matching-symbols): Treat passed filter as an acceptor
+ predicate, not as a rejector.
+
+2007-09-15 Helmut Eller <heller(a)common-lisp.net>
+
+ Add the necessary hooks when loading some contribs, so that those
+ contribs can be easily loaded with slime-setup.
+
+ * slime-highlight-edits.el (slime-highlight-edits-mode-on): New
+ function. Add this to slime-mode-hook by default.
+
+ * slime-autodoc.el (slime-use-autodoc-mode): Change default to t.
+
+2007-09-15 Ariel Badichi <abadichi(a)bezeqint.net>
+
+ * swank-fancy-inspector.lisp (inspect-for-emacs package): When
+ inspecting a package, the links in the use list and the used-by
+ list lead to inspecting package names, rather than the packages
+ themselves. Fix that.
+
+2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-parse.el: Fix extended arglist display on misbalanced
+ expressions like `(defun foo | ... (defun bar () 'bar)'
+ Reported by Ariel Badichi.
+
+ (slime-inside-string-p): Use `beginning-of-defun' directly than
+ relying on `slime-region-for-defun-at-point' (as this one uses
+ `end-of-defun' which signals an error on misbalanced expressions.)
+
+2007-09-15 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-fuzzy.lisp: Code reorganization and cleanup; making it
+ compute less and couple of other minor issues fixed on the
+ way. Thanks to Stelian Ionescu for testing and providing feedback!
+
+ (defstruct fuzzy-matching): New `package-name' slot.
+ (make-fuzzy-matching): Updated for new slot.
+ (format-completion-result): Renamed to `fuzzy-format-matching'.
+ (%fuzzy-extract-matching-info): Helper for `fuzzy-format-matching'.
+
+ (fuzzy-completion-set): Convert the matchings after they got
+ truncated to the passed completion-set limit from Emacs.
+ I.e. `slime-fuzzy-completion-limit' This means a huge
+ computational reduction.
+
+ (fuzzy-create-completion-set): Renamed to `fuzzy-generate-matchings'.
+ (fuzzy-generate-matchings): Returns the fuzzy matchings
+ themselves, do not yet convert them for Emacs. Do not perform two
+ sorts on the generated matchings (first alphabetically, then per
+ score), but just one with an appropriate predicate that sorts per
+ score, unless matchings are equal, then sort alphabetically. Prune
+ matchings with symbols which are found in a differenta package
+ than their home package when the home package is among the matched
+ packages. Try to take the time needed to sort the generated
+ matchings into account for the time-limit.
+ (%guess-sort-duration): Helper.
+ Tries to guess how long the sort will take.
+ (%make-duplicate-symbols-filter): Helper.
+ Used for pruning of matchings.
+ (fuzzy-matching-greaterp): New testing predicate for sorting.
+
+ (fuzzy-find-matching-symbols): Now takes a :filter keyarg; only
+ considers symbols that pass through the filter.
+ (fuzzy-find-matching-packages): Do not return matchings for all
+ nicknames of package, but just the one that matches best.
+
+2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-editing-commands.el: Automatically bind the editing
+ commands when this module is required. (Previously, one had to
+ enable them explicitly, but this is inconsistent to, for instance,
+ the `slime-c-p-c' module which also sets up its bindings
+ automatically.)
+ (slime-bind-editing-commands): Renamed to `slime-editing-commands-init'.
+ (slime-editing-commands-init): Evaluated at toplevel.
+
+2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-parse.el (slime-enclosing-form-specs): Now also works even
+ when point is inside a string.
+ (slime-inside-string-p): New function.
+ (slime-beginning-of-string): New function.
+
+2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglist.lisp (read-conversatively-for-autodoc): Also parse
+ quoted symbols explicitly. This fixed extended arglist display for
+ `(make-instance 'foo'. Reported by: Johannes Groedem.
+
+2007-09-11 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-fancy.el: Require `slime-references'.
+
+2007-09-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package):
+ Move from slime.el to contrib/slime-parse.el.
+
+2007-09-10 Helmut Eller <heller(a)common-lisp.net>
+
+ * inferior-slime.el: Fix installation comment.
+
+2007-09-10 Helmut Eller <heller(a)common-lisp.net>
+
+ Fix some of the bugs introduced with the last change.
+
+ * slime-references.el (sldb-reference-face): Add missing quote.
+ (sldb-reference-properties): We are lucky and can use keywords
+ instead of strings.
+ (sldb-maybe-insert-references): Insert newlines differently.
+
+2007-09-10 Helmut Eller <heller(a)common-lisp.net>
+
+ Move SBCL doc references to contrib.
+
+ * slime-references.el: New file.
+
+2007-09-10 Attila Lendvai <attila.lendvai(a)gmail.com>
+
+ * slime-fuzzy.el: Fixed some race condition that prevented a
+ proper closing of the *Fuzzy Completions* buffer in some
+ circumstances.
+
+ (slime-fuzzy-save-window-configuration): Removed. Hooking up
+ `window-configuration-change-hook' via `run-with-timer' was racy
+ and lead to this bug; we now set the hook explicitely at the
+ necessary place instead.
+ (slime-fuzzy-window-configuration-change-add-hook): Removed.
+ (slime-fuzzy-choices-buffer): Explicitly save the
+ window-configuration, and explicitly set the hook.
+ (slime-fuzzy-done): Explicitely remove the hook.
+
+2007-09-10 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package):
+ Moved back into slime.el.
+
+2007-09-08 Stelian Ionescu <sionescu(a)common-lisp.net>
+
+ * slime-banner.el: Fixed typo to provide `slime-banner', not
+ `slime-startup-animation'.
+
+2007-09-06 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime-presentations.el (slime-presentation-write): Use case, not
+ ecase, for dispatching targets. Should fix XEmacs compatibility.
+ Reported by Steven E. Harris.
+
+2007-09-05 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-c-p-c.el: This file incorrectly provided the module
+ `:swank-compound-prefix'; changed that to `:swank-c-p-c'.
+
+ This gets rid off the nasty redefinition warnings that were
+ previously signalled when loading SWANK with SBCL.
+
+ * swank-arglist.lisp (arglist-for-echo-area): Locally declare
+ `*arglist-pprint-bindings*' to be special, as the variable is
+ defined later in the file. (Gets rid of warnings during loading.)
+
+2007-09-05 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * slime-c-p-c.el (slime-c-p-c-init): Bind `slime-complete-form' to
+ `C-c C-s' in `slime-repl-mode-map'.
+
+2007-09-05 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Added extended arglist display for DECLAIM and PROCLAIM.
+
+ * slime-parse.el (slime-extended-operator-name-parser-alist): Added
+ entries for "DECLAIM", and "PROCLAIM".
+ (slime-parse-extended-operator/declare): Provide information about
+ the operator the arglist is requested for.
+ (slime-make-form-spec-from-string): Fixed for "()" as input.
+
+ * swank-arglists.lisp (valid-operator-symbol-p): Explicitly allow
+ the symbol 'DECLARE.
+ (arglist-dispatch): New method for `DECLARE'. We have to catch
+ this explicitly, as DECLARE doesn't have an arglist (in the
+ `swank-backend:arglist' sense.)
+ (*arglist-pprint-bindings*): New variable. Splitted out from
+ `decoded-arglist-to-string'.
+ (decoded-arglist-to-string): Use `*arglist-pprint-bindings*'.
+
+ (parse-first-valid-form-spec): Rewritten, because function
+ signature had to be changed: doesn't take arg-indices anymore;
+ returns position of first valid spec as second value to remedy.
+ (arglist-for-echo-area): Accomodated to new signature of
+ `parse-first-valid-form-spec'; now searchs for contextual
+ declaration operator name, to prefix a declaration arglist by
+ "declare", "declaim", or "proclaim" depending on what was used at
+ user's point in Slime. Use `*arglist-pprint-bindings*' for
+ printing the found declaration operator name.
+ (%find-declaration-operator): New helper to do this search.
+ (completions-for-keyword): Accomodated to new signature of
+ `parse-first-valid-form-spec'. Also fixed to correctly provide
+ keyword completions in nested expressions like:
+
+ `(defun foo (x)
+ (let ((bar 'quux))
+ (with-open-file (s f :|' [`|' being point]
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-arglists.lisp (parse-first-valid-form-spec): Rewrite it for
+ ABCL.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Some bug fixes for slime-complete-symbol*.
+ Patches by Mr. Madhu <enometh(a)meer.net>
+
+ * slime-c-p-c.el (slime-c-p-c-unambiguous-prefix-p): New variable.
+ (slime-expand-abbreviations-and-complete): Use it. Also add a
+ workaround for XEmacs issues.
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ Move asdf support to contrib:
+
+ * slime-asdf.el: New file.
+
+ * swank-asdf.lisp: New file
+ (operate-on-system, asdf-central-registry)
+ (list-all-systems-known-to-asdf): Use the asdf package in the
+ source code, i.e. write asdf:operate instead of
+ (find-symbol "OPERATE" "ASDF").
+
+2007-09-04 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-tramp.el: New file.
+ * slime-banner.el: New file.
+ * inferior-slime.el: New file.
+
+2007-09-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime-fancy.el: New meta-contrib.
+
+2007-09-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime-presentations.el (slime-dispatch-presentation-event):
+ Explicitly return t to indicate the events have been handled,
+ rather than relying on the return values of the called functions.
+
+2007-09-01 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime-typeout-frame.el (slime-typeout-autodoc-message): Fix for
+ messages that contain "%". Reported by Martin Simmons.
+
+2007-09-01 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Makes `slime-complete-form' work on `(eval-when |'; doesn't work
+ on `(eval-when (|' yet.
+
+ * slime-parse.el (slime-parse-sexp-at-point): Guard against
+ `(char-after)' being NIL at end of buffer (especially important
+ for use on the REPL.)
+
+ * swank-arglist.lisp (arglist-dispatch 'eval-when): Fix typo.
+ (print-decoded-arglist-as-template): Print keywords with PRIN1.
+
+2007-08-31 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ Added extended arglist display for EVAL-WHEN, viz:
+
+ (eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)
+
+ Notice that completion works as expected on these keywords.
+
+ Die, EVAL-ALWAYS, die!
+
+ * swank-arglist (arglist-dispatch): New method for EVAL-WHEN.
+ (print-arglist): Print keywords with PRIN1 rather than PRINC,
+ to get a result as shown above for the EVAL-WHEN case.
+ (completions-for-keyword): Add support for &ANY args.
+
+2007-08-31 Tobias C. Rittweiler <tcr(a)freebits.de>
+
+ * swank-arglist.lisp: Do not fall back to READ when interpreting
+ the ``raw form specs'' comming from Slime's autodoc stuff. But
+ still do so for those comming from `slime-complete-form'.
+
+ (unintern-in-home-package): New.
+
+ (*arglist-dummy*): New.
+ (read-conversatively-for-autodoc): New function. Doesn't READ
+ anything that comes from Slime's autodoc. Just tries to parse
+ symbols. If that's not successfull, returns the dummy placeholder
+ datum stored in `*arglist-dummy*'.
+ (arglist-for-echo-area): Parse form-specs using
+ `read-conversatively-for-autodoc'. Use `unintern-in-home-package'.
+
+ (read-softly): New. Splitted out from `read-form-spec'. This
+ function tries to keep track of newly interned functions before
+ READing.
+ (read-form-spec): Parametrized to take a function to read the
+ elements of the passed ``raw form spec''. Uses `read-softly' as
+ default reader.
+
+ (complete-form, completions-for-keywords):
+ Use `unintern-in-home-package'.
+
+2007-08-31 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-autodoc.el: Add installation notes.
+ * slime-editing-commands.el: Add installation notes.
+ * slime-c-p-c.el (slime-c-p-c-init): Fix typos.
+
+2007-08-31 Helmut Eller <heller(a)common-lisp.net>
+
+ Move compound prefix completion and autodoc to contrib.
+ Interdependencies made it almost necessary to move parsing code
+ and editing commands in the same patch.
+
+ * slime-c-p-c.el: New file.
+ * swank-c-p-c.el: New file.
+ * slime-parse.el: New file.
+ * swank-arglists.el: New file.
+ * slime-editing-commands.el: New file.
+ * slime-autodoc.el: New file.
+
+2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * slime-presentations.el (slime-last-output-target-id)
+ (slime-output-target-to-marker, slime-output-target-marker)
+ (slime-redirect-trace-output): Moved back into SLIME core.
+
+ * swank-presentation-streams.lisp: Require swank-presentations.
+ (present-repl-results-via-presentation-streams): New.
+ (*send-repl-results-function*): Set this variable rather than
+ overriding send-repl-results-to-emacs.
+
+2007-08-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-presentations.el (slime-clear-presentations): New
+ function. Add it to slime-repl-clear-buffer-hook.
+
+2007-08-28 Helmut Eller <heller(a)common-lisp.net>
+
+ * swank-listener-hooks.lisp: New file
+
+2007-08-28 Helmut Eller <heller(a)common-lisp.net>
+
+ Move the rest of the presentation related code.
+
+ * swank-presentations.lisp (present-repl-results): Renamed from
+ send-repl-results-to-emacs.
+
+2007-08-28 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ * swank-presentations.lisp (send-repl-results-to-emacs):
+ Override core defun to mark up REPL results as presentations.
+
+ * swank-presentations.lisp: New file.
+ * slime-presentations.el: Load it.
+
+ * slime-presentations.el (slime-presentation-write): Remove id
+ argument.
+
+ * slime-presentation-streams.el: Require slime-presentations contrib.
+
+2007-08-27 Helmut Eller <heller(a)common-lisp.net>
+
+ Move presentations to contrib. (ELisp part)
+
+ * slime-presentations.el: New file.
+ * slime-scratch.el (slime-scratch-buffer): Ignore presentations.
+
+2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Some fixes to the presentation-streams contrib.
+
+ * swank-presentation-streams.lisp [sbcl]: Load the pretty-printer
+ patch only at load time. Add some trickery so that SBCL does not
+ complain about the changed layout of the pretty-stream class.
+
+ * swank-presentation-streams.lisp (slime-stream-p): Using special
+ return values, indicate whether we are printing to the
+ REPL-results stream, or a dedicated stream.
+ (presentation-record): New slot "target".
+ (presentation-start, presentation-end): Use it (rather than the
+ global variable *use-dedicated-output-stream*) to decide whether
+ to use the bridge protocol or the :presentation-start/-end
+ protocol. Also use it as the TARGET argument of
+ :presentation-start/-end messages.
+ (presenting-object-1): Use the new return values of
+ slime-stream-p.
+
+ * swank-presentation-streams.lisp (slime-stream-p) [cmu]: Use the
+ return value of slime-stream-p rather than the global variable
+ *use-dedicated-output-stream* to decide whether printing through
+ pretty streams is safe for the layout.
+
+2007-08-24 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+
+ Make the fancy "presentation streams" feature a contrib.
+ Previously, it was only available if "present.lisp" was loaded
+ manually.
+
+ * slime-presentation-streams.el: New file.
+ * swank-presentation-streams.lisp: New file, moved here from
+ ../present.lisp
+
+2007-08-24 Helmut Eller <heller(a)common-lisp.net>
+
+ * slime-typeout-frame.el: New file.
+ * slime-xref-browser.el: New file.
+ * slime-highlight-edits.el: New file.
+ * slime-scratch.el: New file.
+
+2007-08-23 Helmut Eller <heller(a)common-lisp.net>
+
+ Move Marco Baringer's inspector to contrib.
+
+ * swank-fancy-inspector.lisp: New file. The only difference to the
+ code is that inspect-for-emacs methods in this file are
+ specialized to the new class `fancy-inspector'.
+ (fancy-inspector): New class.
+
+ * slime-fancy-inspector.el: New file.
+
+2007-08-19 Helmut Eller <heller(a)common-lisp.net>
+
+ Moved fuzzy completion code to contrib directory.
+
+ * slime-fuzzy.el: New file.
+ (slime-fuzzy-init): New function. Load CL code on startup.
+
+ * swank-fuzzy.lisp: New file. Common Lisp code for fuzzy
+ completion.
Added: branches/bos/thirdparty/emacs/slime/contrib/README
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/README Fri Jan 18 06:05:59 2008
@@ -0,0 +1,30 @@
+This directory contains source code which may be useful to some Slime
+users. *.el files are Emacs Lisp source and *.lisp files contain
+Common Lisp source code. If not otherwise stated in the file itself,
+the files are placed in the Public Domain.
+
+The components in this directory are more or less detached from the
+rest of Slime. They are essentially "add-ons". But Slime can also be
+used without them. The code is maintained by the respective authors.
+
+To use the packages here, you should add this directory to your Emacs
+load-path, require the contrib, and call the contrib's init function to
+enable the functionality that's provided by the respective contrib.
+
+E.g. for fuzzy completion add this to your .emacs:
+
+ (add-to-list 'load-path "<this-directory>")
+ (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy)
+ (slime-fuzzy-init)))
+
+Alternatively, you can use the `slime-setup' function which takes a
+list of contrib names, and which loads and enables them automatically
+for you:
+
+ (slime-setup '(slime-fancy slime-asdf slime-tramp ...))
+
+
+Finally, the contrib `slime-fancy' is specially noteworthy, as it
+represents a meta-contrib that'll load a bunch of commonly used
+contribs. Look into `slime-fancy.el' to find out which.
+
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/bridge.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/bridge.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,467 @@
+;;; -*-Emacs-Lisp-*-
+;;;%Header
+;;; Bridge process filter, V1.0
+;;; Copyright (C) 1991 Chris McConnell, ccm(a)cs.cmu.edu
+;;;
+;;; Send mail to ilisp(a)cons.org if you have problems.
+;;;
+;;; Send mail to majordomo(a)cons.org if you want to be on the
+;;; ilisp mailing list.
+
+;;; This file is part of GNU Emacs.
+
+;;; GNU Emacs is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY. No author or distributor
+;;; accepts responsibility to anyone for the consequences of using it
+;;; or for whether it serves any particular purpose or works at all,
+;;; unless he says so in writing. Refer to the GNU Emacs General Public
+;;; License for full details.
+
+;;; Everyone is granted permission to copy, modify and redistribute
+;;; GNU Emacs, but only under the conditions described in the
+;;; GNU Emacs General Public License. A copy of this license is
+;;; supposed to have been given to you along with GNU Emacs so you
+;;; can know your rights and responsibilities. It should be in a
+;;; file named COPYING. Among other things, the copyright notice
+;;; and this notice must be preserved on all copies.
+
+;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting
+;;; the process filter for continuous handlers.
+
+;;; USAGE: M-x install-bridge will add a process output filter to the
+;;; current buffer. Any output that the process does between
+;;; bridge-start-regexp and bridge-end-regexp will be bundled up and
+;;; passed to the first handler on bridge-handlers that matches the
+;;; output using string-match. If bridge-prompt-regexp shows up
+;;; before bridge-end-regexp, the bridge will be cancelled. If no
+;;; handler matches the output, the first symbol in the output is
+;;; assumed to be a buffer name and the rest of the output will be
+;;; sent to that buffer's process. This can be used to communicate
+;;; between processes or to set up two way interactions between Emacs
+;;; and an inferior process.
+
+;;; You can write handlers that process the output in special ways.
+;;; See bridge-send-handler for the default handler. The command
+;;; hand-bridge is useful for testing. Keep in mind that all
+;;; variables are buffer local.
+
+;;; YOUR .EMACS FILE:
+;;;
+;;; ;;; Set up load path to include bridge
+;;; (setq load-path (cons "/bridge-directory/" load-path))
+;;; (autoload 'install-bridge "bridge" "Install a process bridge." t)
+;;; (setq bridge-hook
+;;; '(lambda ()
+;;; ;; Example options
+;;; (setq bridge-source-insert nil) ;Don't insert in source buffer
+;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer
+;;; ;; Handle copy-it messages yourself
+;;; (setq bridge-handlers
+;;; '(("copy-it" . my-copy-handler)))))
+
+;;; EXAMPLE:
+;;; # This pipes stdin to the named buffer in a Unix shell
+;;; alias devgnu '(echo -n "\!* "; cat -; echo -n " ")'
+;;;
+;;; ls | devgnu *scratch*
+
+(eval-when-compile
+ (require 'cl))
+
+;;;%Parameters
+(defvar bridge-hook nil
+ "Hook called when a bridge is installed by install-hook.")
+
+(defvar bridge-start-regexp ""
+ "*Regular expression to match the start of a process bridge in
+process output. It should be followed by a buffer name, the data to
+be sent and a bridge-end-regexp.")
+
+(defvar bridge-end-regexp " "
+ "*Regular expression to match the end of a process bridge in process
+output.")
+
+(defvar bridge-prompt-regexp nil
+ "*Regular expression for detecting a prompt. If there is a
+comint-prompt-regexp, it will be initialized to that. A prompt before
+a bridge-end-regexp will stop the process bridge.")
+
+(defvar bridge-handlers nil
+ "Alist of (regexp . handler) for handling process output delimited
+by bridge-start-regexp and bridge-end-regexp. The first entry on the
+list whose regexp matches the output will be called on the process and
+the delimited output.")
+
+(defvar bridge-source-insert t
+ "*T to insert bridge input in the source buffer minus delimiters.")
+
+(defvar bridge-destination-insert t
+ "*T for bridge-send-handler to insert bridge input into the
+destination buffer minus delimiters.")
+
+(defvar bridge-chunk-size 512
+ "*Long inputs send to comint processes are broken up into chunks of
+this size. If your process is choking on big inputs, try lowering the
+value.")
+
+;;;%Internal variables
+(defvar bridge-old-filter nil
+ "Old filter for a bridged process buffer.")
+
+(defvar bridge-string nil
+ "The current output in the process bridge.")
+
+(defvar bridge-in-progress nil
+ "The current handler function, if any, that bridge passes strings on to,
+or nil if none.")
+
+(defvar bridge-leftovers nil
+ "Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.")
+
+(defvar bridge-send-to-buffer nil
+ "The buffer that the default bridge-handler (bridge-send-handler) is
+currently sending to, or nil if it hasn't started yet. Your handler
+function can use this variable also.")
+
+(defvar bridge-last-failure ()
+ "Last thing that broke the bridge handler. First item is function call
+(eval'able); last item is error condition which resulted. This is provided
+to help handler-writers in their debugging.")
+
+;;;%Utilities
+(defun bridge-insert (output)
+ "Insert process OUTPUT into the current buffer."
+ (if output
+ (let* ((buffer (current-buffer))
+ (process (get-buffer-process buffer))
+ (mark (process-mark process))
+ (window (selected-window))
+ (at-end nil))
+ (if (eq (window-buffer window) buffer)
+ (setq at-end (= (point) mark))
+ (setq window (get-buffer-window buffer)))
+ (save-excursion
+ (goto-char mark)
+ (insert output)
+ (set-marker mark (point)))
+ (if window
+ (progn
+ (if at-end (goto-char mark))
+ (if (not (pos-visible-in-window-p (point) window))
+ (let ((original (selected-window)))
+ (save-excursion
+ (select-window window)
+ (recenter '(center))
+ (select-window original)))))))))
+
+;;;
+;(defun bridge-send-string (process string)
+; "Send PROCESS the contents of STRING as input.
+;This is equivalent to process-send-string, except that long input strings
+;are broken up into chunks of size comint-input-chunk-size. Processes
+;are given a chance to output between chunks. This can help prevent processes
+;from hanging when you send them long inputs on some OS's."
+; (let* ((len (length string))
+; (i (min len bridge-chunk-size)))
+; (process-send-string process (substring string 0 i))
+; (while (< i len)
+; (let ((next-i (+ i bridge-chunk-size)))
+; (accept-process-output)
+; (process-send-string process (substring string i (min len next-i)))
+; (setq i next-i)))))
+
+;;;
+(defun bridge-call-handler (handler proc string)
+ "Funcall HANDLER on PROC, STRING carefully. Error is caught if happens,
+and user is signaled. State is put in bridge-last-failure. Returns t if
+handler executed without error."
+ (let ((inhibit-quit nil)
+ (failed nil))
+ (condition-case err
+ (funcall handler proc string)
+ (error
+ (ding)
+ (setq failed t)
+ (message "bridge-handler \"%s\" failed %s (see bridge-last-failure)"
+ handler err)
+ (setq bridge-last-failure
+ (` ((funcall '(, handler) '(, proc) (, string))
+ "Caused: "
+ (, err))))))
+ (not failed)))
+
+;;;%Handlers
+(defun bridge-send-handler (process input)
+ "Send PROCESS INPUT to the buffer name found at the start of the
+input. The input after the buffer name is sent to the buffer's
+process if it has one. If bridge-destination-insert is T, the input
+will be inserted into the buffer. If it does not have a process, it
+will be inserted at the end of the buffer."
+ (if (null input)
+ (setq bridge-send-to-buffer nil) ; end of bridge
+ (let (buffer-and-start buffer-name dest to)
+ ;; if this is first time, get the buffer out of the first line
+ (cond ((not bridge-send-to-buffer)
+ (setq buffer-and-start (read-from-string input)
+ buffer-name (format "%s" (car (read-from-string input)))
+ dest (get-buffer buffer-name)
+ to (get-buffer-process dest)
+ input (substring input (cdr buffer-and-start)))
+ (setq bridge-send-to-buffer dest))
+ (t
+ (setq buffer-name bridge-send-to-buffer
+ dest (get-buffer buffer-name)
+ to (get-buffer-process dest)
+ )))
+ (if dest
+ (let ((buffer (current-buffer)))
+ (if bridge-destination-insert
+ (unwind-protect
+ (progn
+ (set-buffer dest)
+ (if to
+ (bridge-insert process input)
+ (goto-char (point-max))
+ (insert input)))
+ (set-buffer buffer)))
+ (if to
+ ;; (bridge-send-string to input)
+ (process-send-string to input)
+ ))
+ (error "%s is not a buffer" buffer-name)))))
+
+;;;%Filter
+(defun bridge-filter (process output)
+ "Given PROCESS and some OUTPUT, check for the presence of
+bridge-start-regexp. Everything prior to this will be passed to the
+normal filter function or inserted in the buffer if it is nil. The
+output up to bridge-end-regexp will be sent to the first handler on
+bridge-handlers that matches the string. If no handlers match, the
+input will be sent to bridge-send-handler. If bridge-prompt-regexp is
+encountered before the bridge-end-regexp, the bridge will be cancelled."
+ (let ((inhibit-quit t)
+ (match-data (match-data))
+ (buffer (current-buffer))
+ (process-buffer (process-buffer process))
+ (case-fold-search t)
+ (start 0) (end 0)
+ function
+ b-start b-start-end b-end)
+ (set-buffer process-buffer) ;; access locals
+
+ ;; Handle bridge messages that straddle a packet by prepending
+ ;; them to this packet.
+
+ (when bridge-leftovers
+ (setq output (concat bridge-leftovers output))
+ (setq bridge-leftovers nil))
+
+ (setq function bridge-in-progress)
+
+ ;; How it works:
+ ;;
+ ;; start, end delimit the part of string we are interested in;
+ ;; initially both 0; after an iteration we move them to next string.
+
+ ;; b-start, b-end delimit part of string to bridge (possibly whole string);
+ ;; this will be string between corresponding regexps.
+
+ ;; There are two main cases when we come into loop:
+
+ ;; bridge in progress
+ ;;0 setq b-start = start
+ ;;1 setq b-end (or end-pattern end)
+ ;;4 process string
+ ;;5 remove handler if end found
+
+ ;; no bridge in progress
+ ;;0 setq b-start if see start-pattern
+ ;;1 setq b-end if bstart to (or end-pattern end)
+ ;;2 send (substring start b-start) to normal place
+ ;;3 find handler (in b-start, b-end) if not set
+ ;;4 process string
+ ;;5 remove handler if end found
+
+ ;; equivalent sections have the same numbers here;
+ ;; we fold them together in this code.
+
+ (block bridge-filter
+ (unwind-protect
+ (while (< end (length output))
+
+ ;;0 setq b-start if find
+ (setq b-start
+ (cond (bridge-in-progress
+ (setq b-start-end start)
+ start)
+ ((string-match bridge-start-regexp output start)
+ (setq b-start-end (match-end 0))
+ (match-beginning 0))
+ (t nil)))
+ ;;1 setq b-end
+ (setq b-end
+ (if b-start
+ (let ((end-seen (string-match bridge-end-regexp
+ output b-start-end)))
+ (if end-seen (setq end (match-end 0)))
+
+ end-seen)))
+
+ ;; Detect and save partial bridge messages
+ (when (and b-start b-start-end (not b-end))
+ (setq bridge-leftovers (substring output b-start))
+ )
+
+ (if (and b-start (not b-end))
+ (setq end b-start)
+ (if (not b-end)
+ (setq end (length output))))
+
+ ;;1.5 - if see prompt before end, remove current
+ (if (and b-start b-end)
+ (let ((prompt (string-match bridge-prompt-regexp
+ output b-start-end)))
+ (if (and prompt (<= (match-end 0) b-end))
+ (setq b-start nil ; b-start-end start
+ b-end start
+ end (match-end 0)
+ bridge-in-progress nil
+ ))))
+
+ ;;2 send (substring start b-start) to old filter, if any
+ (when (not (equal start (or b-start end))) ; don't bother on empty string
+ (let ((pass-on (substring output start (or b-start end))))
+ (if bridge-old-filter
+ (let ((old bridge-old-filter))
+ (store-match-data match-data)
+ (funcall old process pass-on)
+ ;; if filter changed, re-install ourselves
+ (let ((new (process-filter process)))
+ (if (not (eq new 'bridge-filter))
+ (progn (setq bridge-old-filter new)
+ (set-process-filter process 'bridge-filter)))))
+ (set-buffer process-buffer)
+ (bridge-insert pass-on))))
+
+ (if (and b-start-end (not b-end))
+ (return-from bridge-filter t) ; when last bit has prematurely ending message, exit early.
+ (progn
+ ;;3 find handler (in b-start, b-end) if none current
+ (if (and b-start (not bridge-in-progress))
+ (let ((handlers bridge-handlers))
+ (while (and handlers (not function))
+ (let* ((handler (car handlers))
+ (m (string-match (car handler) output b-start-end)))
+ (if (and m (< m b-end))
+ (setq function (cdr handler))
+ (setq handlers (cdr handlers)))))
+ ;; Set default handler if none
+ (if (null function)
+ (setq function 'bridge-send-handler))
+ (setq bridge-in-progress function)))
+ ;;4 process strin
+ (if function
+ (let ((ok t))
+ (if (/= b-start-end b-end)
+ (let ((send (substring output b-start-end b-end)))
+ ;; also, insert the stuff in buffer between
+ ;; iff bridge-source-insert.
+ (if bridge-source-insert (bridge-insert send))
+ ;; call handler on string
+ (setq ok (bridge-call-handler function process send))))
+ ;;5 remove handler if end found
+ ;; if function removed then tell it that's all
+ (if (or (not ok) (/= b-end end)) ;; saw end before end-of-string
+ (progn
+ (bridge-call-handler function process nil)
+ ;; have to remove function too for next time around
+ (setq function nil
+ bridge-in-progress nil)
+ ))
+ ))
+
+ ;; continue looping, in case there's more string
+ (setq start end))
+ ))
+ ;; protected forms: restore buffer, match-data
+ (set-buffer buffer)
+ (store-match-data match-data)
+ ))))
+
+
+;;;%Interface
+(defun install-bridge ()
+ "Set up a process bridge in the current buffer."
+ (interactive)
+ (if (not (get-buffer-process (current-buffer)))
+ (error "%s does not have a process" (buffer-name (current-buffer)))
+ (make-local-variable 'bridge-start-regexp)
+ (make-local-variable 'bridge-end-regexp)
+ (make-local-variable 'bridge-prompt-regexp)
+ (make-local-variable 'bridge-handlers)
+ (make-local-variable 'bridge-source-insert)
+ (make-local-variable 'bridge-destination-insert)
+ (make-local-variable 'bridge-chunk-size)
+ (make-local-variable 'bridge-old-filter)
+ (make-local-variable 'bridge-string)
+ (make-local-variable 'bridge-in-progress)
+ (make-local-variable 'bridge-send-to-buffer)
+ (make-local-variable 'bridge-leftovers)
+ (setq bridge-string nil bridge-in-progress nil
+ bridge-send-to-buffer nil)
+ (if (boundp 'comint-prompt-regexp)
+ (setq bridge-prompt-regexp comint-prompt-regexp))
+ (let ((process (get-buffer-process (current-buffer))))
+ (if process
+ (if (not (eq (process-filter process) 'bridge-filter))
+ (progn
+ (setq bridge-old-filter (process-filter process))
+ (set-process-filter process 'bridge-filter)))
+ (error "%s does not have a process"
+ (buffer-name (current-buffer)))))
+ (run-hooks 'bridge-hook)
+ (message "Process bridge is installed")))
+
+;;;
+(defun reset-bridge ()
+ "Must be called from the process's buffer. Removes any active bridge."
+ (interactive)
+ ;; for when things get wedged
+ (if bridge-in-progress
+ (unwind-protect
+ (funcall bridge-in-progress (get-buffer-process
+ (current-buffer))
+ nil)
+ (setq bridge-in-progress nil))
+ (message "No bridge in progress.")))
+
+;;;
+(defun remove-bridge ()
+ "Remove bridge from the current buffer."
+ (interactive)
+ (let ((process (get-buffer-process (current-buffer))))
+ (if (or (not process) (not (eq (process-filter process) 'bridge-filter)))
+ (error "%s has no bridge" (buffer-name (current-buffer)))
+ ;; remove any bridge-in-progress
+ (reset-bridge)
+ (set-process-filter process bridge-old-filter)
+ (funcall bridge-old-filter process bridge-string)
+ (message "Process bridge is removed."))))
+
+;;;% Utility for testing
+(defun hand-bridge (start end)
+ "With point at bridge-start, sends bridge-start + string +
+bridge-end to bridge-filter. With prefix, use current region to send."
+ (interactive "r")
+ (let ((p0 (if current-prefix-arg (min start end)
+ (if (looking-at bridge-start-regexp) (point)
+ (error "Not looking at bridge-start-regexp"))))
+ (p1 (if current-prefix-arg (max start end)
+ (if (re-search-forward bridge-end-regexp nil t)
+ (point) (error "Didn't see bridge-end-regexp")))))
+
+ (bridge-filter (get-buffer-process (current-buffer))
+ (buffer-substring-no-properties p0 p1))
+ ))
+
+(provide 'bridge)
Added: branches/bos/thirdparty/emacs/slime/contrib/inferior-slime.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/inferior-slime.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,88 @@
+;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers
+;;
+;; Author: Luke Gorrie <luke(a)synap.se>
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'inferior-slime)))
+;; (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1)))
+
+(define-minor-mode inferior-slime-mode
+ "\\<slime-mode-map>\
+Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs.
+
+This mode is intended for use with `inferior-lisp-mode'. It provides a
+subset of the bindings from `slime-mode'.
+
+\\{inferior-slime-mode-map}"
+ nil
+ nil
+ ;; Fake binding to coax `define-minor-mode' to create the keymap
+ '((" " 'undefined)))
+
+(add-to-list 'minor-mode-alist
+ '(inferior-slime-mode
+ (" Inf-Slime" slime-state-name)))
+
+(defun inferior-slime-return ()
+ "Handle the return key in the inferior-lisp buffer.
+The current input should only be sent if a whole expression has been
+entered, i.e. the parenthesis are matched.
+
+A prefix argument disables this behaviour."
+ (interactive)
+ (if (or current-prefix-arg (inferior-slime-input-complete-p))
+ (comint-send-input)
+ (insert "\n")
+ (inferior-slime-indent-line)))
+
+(defun inferior-slime-indent-line ()
+ "Indent the current line, ignoring everything before the prompt."
+ (interactive)
+ (save-restriction
+ (let ((indent-start
+ (save-excursion
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (let ((inhibit-field-text-motion t))
+ (beginning-of-line 1))
+ (point))))
+ (narrow-to-region indent-start (point-max)))
+ (lisp-indent-line)))
+
+(defun inferior-slime-input-complete-p ()
+ "Return true if the input is complete in the inferior lisp buffer."
+ (slime-input-complete-p (process-mark (get-buffer-process (current-buffer)))
+ (point-max)))
+
+(defun inferior-slime-closing-return ()
+ "Send the current expression to Lisp after closing any open lists."
+ (interactive)
+ (goto-char (point-max))
+ (save-restriction
+ (narrow-to-region (process-mark (get-buffer-process (current-buffer)))
+ (point-max))
+ (while (ignore-errors (save-excursion (backward-up-list 1) t))
+ (insert ")")))
+ (comint-send-input))
+
+(defun inferior-slime-init-keymap ()
+ (let ((map inferior-slime-mode-map))
+ (define-key map [return] 'inferior-slime-return)
+ (define-key map [(control return)] 'inferior-slime-closing-return)
+ (define-key map [(meta control ?m)] 'inferior-slime-closing-return)
+ (define-key map "\C-c\C-d" slime-doc-map)
+ (define-key map "\C-c\C-w" slime-who-map)
+ (loop for (key command . keys) in slime-keys do
+ (destructuring-bind (&key prefixed inferior &allow-other-keys) keys
+ (when prefixed
+ (setq key (concat slime-prefix-key key)))
+ (when inferior
+ (define-key map key command))))))
+
+(inferior-slime-init-keymap)
+
+(provide 'inferior-slime)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-asdf.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-asdf.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,113 @@
+;;; slime-asdf.el -- ASDF support
+;;
+;; Authors: Daniel Barlow <dan(a)telent.net>
+;; Marco Baringer <mb(a)bese.it>
+;; Edi Weitz <edi(a)agharta.de>
+;; and others
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this to your .emacs:
+;;
+;; (add-to-list 'load-path ".../slime/contrib")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-asdf)))
+;;
+
+;; NOTE: `system-name' is a predefined variable in Emacs. Try to
+;; avoid it as local variable name.
+
+
+(defun slime-load-system (&optional system)
+ "Compile and load an ASDF system.
+
+Default system name is taken from first file matching *.asd in current
+buffer's working directory"
+ (interactive (list (slime-read-system-name)))
+ (slime-oos system "LOAD-OP"))
+
+(defvar slime-system-history nil
+ "History list for ASDF system names.")
+
+(defun slime-read-system-name (&optional prompt initial-value)
+ "Read a system name from the minibuffer, prompting with PROMPT."
+ (setq prompt (or prompt "System: "))
+ (let* ((completion-ignore-case nil)
+ (system-names (slime-eval `(swank:list-asdf-systems)))
+ (alist (slime-bogus-completion-alist system-names)))
+ (completing-read prompt alist nil nil
+ (or initial-value (slime-find-asd system-names) "")
+ 'slime-system-history)))
+
+(defun slime-find-asd (system-names)
+ "Tries to find an ASDF system definition in the default
+directory or in the directory belonging to the current buffer and
+returns it if it's in `system-names'."
+ (let* ((asdf-systems-in-directory
+ (mapcar #'file-name-sans-extension
+ (directory-files
+ (file-name-directory (or default-directory
+ (buffer-file-name)))
+ nil "\.asd$"))))
+ (loop for system in asdf-systems-in-directory
+ for candidate = (file-name-sans-extension system)
+ when (find candidate system-names :test #'string-equal)
+ do (return candidate))))
+
+(defun slime-oos (system operation &rest keyword-args)
+ (slime-save-some-lisp-buffers)
+ (slime-display-output-buffer)
+ (message "Performing ASDF %S%s on system %S"
+ operation (if keyword-args (format " %S" keyword-args) "")
+ system)
+ (slime-eval-async
+ `(swank:operate-on-system-for-emacs ,system ,operation ,@keyword-args)
+ (slime-make-compilation-finished-continuation (current-buffer))))
+
+(defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
+ (:handler (lambda ()
+ (interactive)
+ (slime-oos (slime-read-system-name) "LOAD-OP" :force t)))
+ (:one-liner "Recompile and load an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-load-system ("load-system")
+ (:handler (lambda ()
+ (interactive)
+ (slime-oos (slime-read-system-name) "LOAD-OP")))
+ (:one-liner "Compile (as needed) and load an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-test/force-system ("force-test-system")
+ (:handler (lambda ()
+ (interactive)
+ (slime-oos (slime-read-system-name) "TEST-OP" :force t)))
+ (:one-liner "Compile (as needed) and force test an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-test-system ("test-system")
+ (:handler (lambda ()
+ (interactive)
+ (slime-oos (slime-read-system-name) "TEST-OP")))
+ (:one-liner "Compile (as needed) and test an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-compile-system ("compile-system")
+ (:handler (lambda ()
+ (interactive)
+ (slime-oos (slime-read-system-name) "COMPILE-OP")))
+ (:one-liner "Compile (but not load) an ASDF system."))
+
+(defslime-repl-shortcut slime-repl-compile/force-system
+ ("force-compile-system")
+ (:handler (lambda ()
+ (interactive)
+ (slime-oos (slime-read-system-name) "COMPILE-OP" :force t)))
+ (:one-liner "Recompile (but not load) an ASDF system."))
+
+(defun slime-asdf-on-connect ()
+ (slime-eval-async '(swank:swank-require :swank-asdf)))
+
+(defun slime-asdf-init ()
+ (add-hook 'slime-connected-hook 'slime-asdf-on-connect))
+
+(defun slime-asdf-unload ()
+ (remove-hook 'slime-connected-hook 'slime-asdf-on-connect))
+
+(provide 'slime-asdf)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-autodoc.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-autodoc.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,273 @@
+;;; slime-autodoc.el --- show fancy arglist in echo area
+;;
+;; Authors: Luke Gorrie <luke(a)bluetail.com>
+;; Lawrence Mitchell <wence(a)gmx.li>
+;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; and others
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-autodoc)))
+;;
+
+(require 'slime-parse)
+
+(defvar slime-use-autodoc-mode t
+ "When non-nil always enable slime-autodoc-mode in slime-mode.")
+
+(defun slime-fontify-string (string)
+ "Fontify STRING as `font-lock-mode' does in Lisp mode."
+ (with-current-buffer (get-buffer-create " *slime-fontify*")
+ (erase-buffer)
+ (if (not (eq major-mode 'lisp-mode))
+ (lisp-mode))
+ (insert string)
+ (let ((font-lock-verbose nil))
+ (font-lock-fontify-buffer))
+ (goto-char (point-min))
+ (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t)
+ (let ((highlight (match-string 1)))
+ ;; Can't use (replace-match highlight) here -- broken in Emacs 21
+ (delete-region (match-beginning 0) (match-end 0))
+ (slime-insert-propertized '(face highlight) highlight)))
+ (buffer-substring (point-min) (point-max))))
+
+(defun slime-arglist (name)
+ "Show the argument list for NAME."
+ (interactive (list (slime-read-symbol-name "Arglist of: ")))
+ (slime-eval-async
+ `(swank:arglist-for-echo-area (quote (,name)))
+ (lambda (arglist)
+ (if arglist
+ (message "%s" (slime-fontify-string arglist))
+ (error "Arglist not available")))))
+
+
+
+;;;; Autodocs (automatic context-sensitive help)
+
+(defvar slime-autodoc-mode nil
+ "*When non-nil, print documentation about symbols as the point moves.")
+
+(defvar slime-autodoc-cache-type 'last
+ "*Cache policy for automatically fetched documentation.
+Possible values are:
+ nil - none.
+ last - cache only the most recently-looked-at symbol's documentation.
+ The values are stored in the variable `slime-autodoc-cache'.
+
+More caching means fewer calls to the Lisp process, but at the risk of
+using outdated information.")
+
+(defvar slime-autodoc-cache nil
+ "Cache variable for when `slime-autodoc-cache-type' is 'last'.
+The value is (SYMBOL-NAME . DOCUMENTATION).")
+
+(defun slime-autodoc-mode (&optional arg)
+ "Enable `slime-autodoc'."
+ (interactive "P")
+ (cond ((< (prefix-numeric-value arg) 0) (setq slime-autodoc-mode nil))
+ (arg (setq slime-autodoc-mode t))
+ (t (setq slime-autodoc-mode (not slime-autodoc-mode))))
+ (if slime-autodoc-mode
+ (progn
+ (slime-autodoc-start-timer)
+ (add-hook 'pre-command-hook
+ 'slime-autodoc-pre-command-refresh-echo-area t))
+ (slime-autodoc-stop-timer)))
+
+(defvar slime-autodoc-last-message "")
+
+(defun slime-autodoc ()
+ "Print some apropos information about the code at point, if applicable."
+ (destructuring-bind (cache-key retrieve-form) (slime-autodoc-thing-at-point)
+ (let ((cached (slime-get-cached-autodoc cache-key)))
+ (if cached
+ (slime-autodoc-message cached)
+ ;; Asynchronously fetch, cache, and display documentation
+ (slime-eval-async
+ retrieve-form
+ (with-lexical-bindings (cache-key)
+ (lambda (doc)
+ (let ((doc (if doc (slime-fontify-string doc) "")))
+ (slime-update-autodoc-cache cache-key doc)
+ (slime-autodoc-message doc)))))))))
+
+(defcustom slime-autodoc-use-multiline-p nil
+ "If non-nil, allow long autodoc messages to resize echo area display."
+ :type 'boolean
+ :group 'slime-ui)
+
+(defvar slime-autodoc-message-function 'slime-autodoc-show-message)
+
+(defun slime-autodoc-message (doc)
+ "Display the autodoc documentation string DOC."
+ (funcall slime-autodoc-message-function doc))
+
+(defun slime-autodoc-show-message (doc)
+ (unless slime-autodoc-use-multiline-p
+ (setq doc (slime-oneliner doc)))
+ (setq slime-autodoc-last-message doc)
+ (message "%s" doc))
+
+(defun slime-autodoc-message-dimensions ()
+ "Return the available width and height for pretty printing autodoc
+messages."
+ (cond
+ (slime-autodoc-use-multiline-p
+ ;; Use the full width of the minibuffer;
+ ;; minibuffer will grow vertically if necessary
+ (values (window-width (minibuffer-window))
+ nil))
+ (t
+ ;; Try to fit everything in one line; we cut off when displaying
+ (values 1000 1))))
+
+(defun slime-autodoc-pre-command-refresh-echo-area ()
+ (unless (string= slime-autodoc-last-message "")
+ (if (slime-autodoc-message-ok-p)
+ (message "%s" slime-autodoc-last-message)
+ (setq slime-autodoc-last-message ""))))
+
+(defun slime-autodoc-thing-at-point ()
+ "Return a cache key and a swank form."
+ (let ((global (slime-autodoc-global-at-point)))
+ (if global
+ (values (slime-qualify-cl-symbol-name global)
+ `(swank:variable-desc-for-echo-area ,global))
+ (multiple-value-bind (operators arg-indices points)
+ (slime-enclosing-form-specs)
+ (values (mapcar* (lambda (designator arg-index)
+ (cons
+ (if (symbolp designator)
+ (slime-qualify-cl-symbol-name designator)
+ designator)
+ arg-index))
+ operators arg-indices)
+ (multiple-value-bind (width height)
+ (slime-autodoc-message-dimensions)
+ `(swank:arglist-for-echo-area ',operators
+ :arg-indices ',arg-indices
+ :print-right-margin ,width
+ :print-lines ,height)))))))
+
+(defun slime-autodoc-global-at-point ()
+ "Return the global variable name at point, if any."
+ (when-let (name (slime-symbol-name-at-point))
+ (if (slime-global-variable-name-p name) name)))
+
+(defcustom slime-global-variable-name-regexp "^\\(.*:\\)?\\([*+]\\).+\\2$"
+ "Regexp used to check if a symbol name is a global variable.
+
+Default value assumes +this+ or *that* naming conventions."
+ :type 'regexp
+ :group 'slime)
+
+(defun slime-global-variable-name-p (name)
+ "Is NAME a global variable?
+Globals are recognised purely by *this-naming-convention*."
+ (and (< (length name) 80) ; avoid overflows in regexp matcher
+ (string-match slime-global-variable-name-regexp name)))
+
+(defun slime-get-cached-autodoc (symbol-name)
+ "Return the cached autodoc documentation for SYMBOL-NAME, or nil."
+ (ecase slime-autodoc-cache-type
+ ((nil) nil)
+ ((last)
+ (when (equal (car slime-autodoc-cache) symbol-name)
+ (cdr slime-autodoc-cache)))
+ ((all)
+ (when-let (symbol (intern-soft symbol-name))
+ (get symbol 'slime-autodoc-cache)))))
+
+(defun slime-update-autodoc-cache (symbol-name documentation)
+ "Update the autodoc cache for SYMBOL with DOCUMENTATION.
+Return DOCUMENTATION."
+ (ecase slime-autodoc-cache-type
+ ((nil) nil)
+ ((last)
+ (setq slime-autodoc-cache (cons symbol-name documentation)))
+ ((all)
+ (put (intern symbol-name) 'slime-autodoc-cache documentation)))
+ documentation)
+
+
+;;;;; Asynchronous message idle timer
+
+(defvar slime-autodoc-idle-timer nil
+ "Idle timer for the next autodoc message.")
+
+(defvar slime-autodoc-delay 0.2
+ "*Delay before autodoc messages are fetched and displayed, in seconds.")
+
+(defun slime-autodoc-start-timer ()
+ "(Re)start the timer that prints autodocs every `slime-autodoc-delay' seconds."
+ (interactive)
+ (when slime-autodoc-idle-timer
+ (cancel-timer slime-autodoc-idle-timer))
+ (setq slime-autodoc-idle-timer
+ (run-with-idle-timer slime-autodoc-delay slime-autodoc-delay
+ 'slime-autodoc-timer-hook)))
+
+(defun slime-autodoc-stop-timer ()
+ "Stop the timer that prints autodocs.
+See also `slime-autodoc-start-timer'."
+ (when slime-autodoc-idle-timer
+ (cancel-timer slime-autodoc-idle-timer)
+ (setq slime-autodoc-idle-timer nil)))
+
+(defun slime-autodoc-timer-hook ()
+ "Function to be called after each Emacs becomes idle.
+When `slime-autodoc-mode' is non-nil, print apropos information about
+the symbol at point if applicable."
+ (when (slime-autodoc-message-ok-p)
+ (condition-case err
+ (slime-autodoc)
+ (error
+ (setq slime-autodoc-mode nil)
+ (message "Error: %S; slime-autodoc-mode now disabled." err)))))
+
+(defun slime-autodoc-message-ok-p ()
+ "Return true if printing a message is currently okay (shouldn't
+annoy the user)."
+ (and (or slime-mode (eq major-mode 'slime-repl-mode)
+ (eq major-mode 'sldb-mode))
+ slime-autodoc-mode
+ (or (null (current-message))
+ (string= (current-message) slime-autodoc-last-message))
+ (not executing-kbd-macro)
+ (not (and (boundp 'edebug-active) (symbol-value 'edebug-active)))
+ (not cursor-in-echo-area)
+ (not (active-minibuffer-window))
+ (not (eq (selected-window) (minibuffer-window)))
+ (slime-background-activities-enabled-p)))
+
+
+;;; Initialization
+
+(defun slime-autodoc-init ()
+ (setq slime-echo-arglist-function 'slime-autodoc)
+ (add-hook 'slime-connected-hook 'slime-autodoc-on-connect)
+ (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
+ (add-hook h 'slime-autodoc-maybe-enable)))
+
+(defun slime-autodoc-on-connect ()
+ (slime-eval-async '(swank:swank-require :swank-arglists)))
+
+(defun slime-autodoc-maybe-enable ()
+ (when slime-use-autodoc-mode
+ (slime-autodoc-mode 1)))
+
+(defun slime-autodoc-unload ()
+ (setq slime-echo-arglist-function 'slime-show-arglist)
+ (remove-hook 'slime-connected-hook 'slime-autodoc-on-connect)
+ (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
+ (remove-hook h 'slime-autodoc-maybe-enable)))
+
+(provide 'slime-autodoc)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-banner.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-banner.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,44 @@
+;;; slime-banner.el -- Persistent header line and startup animation
+;;
+;; Authors: Helmut Eller <heller(a)common-lisp.net>
+;; Luke Gorrie <luke(a)synap.se>
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this to your .emacs:
+;;
+;; (add-to-list 'load-path ".../slime/contrib")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-banner)))
+
+(defcustom slime-startup-animation (fboundp 'animate-string)
+ "Enable the startup animation."
+ :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+ :group 'slime-ui)
+
+(defcustom slime-header-line-p (boundp 'header-line-format)
+ "If non-nil, display a header line in Slime buffers."
+ :type 'boolean
+ :group 'slime-repl)
+
+(defun slime-startup-message ()
+ (when slime-header-line-p
+ (setq header-line-format
+ (format "%s Port: %s Pid: %s"
+ (slime-lisp-implementation-type)
+ (slime-connection-port (slime-connection))
+ (slime-pid))))
+ (when (zerop (buffer-size))
+ (let ((welcome (concat "; SLIME " (or (slime-changelog-date)
+ "- ChangeLog file not found"))))
+ (if slime-startup-animation
+ (animate-string welcome 0 0)
+ (insert welcome)))))
+
+(defun slime-banner-init ()
+ (setq slime-repl-banner-function 'slime-startup-message))
+
+(defun slime-banner-unload ()
+ (setq slime-repl-banner-function 'slime-repl-insert-banner))
+
+(provide 'slime-banner)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-c-p-c.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-c-p-c.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,202 @@
+;;; slime-c-p-c.el --- ILISP style Compound Prefix Completion
+;;
+;; Authors: Luke Gorrie <luke(a)synap.se>
+;; Edi Weitz <edi(a)agharta.de>
+;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; and others
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-c-p-c)))
+;;
+
+
+
+(require 'slime)
+(require 'slime-parse)
+(require 'slime-editing-commands)
+
+(defcustom slime-c-p-c-unambiguous-prefix-p t
+ "If true, set point after the unambigous prefix.
+If false, move point to the end of the inserted text."
+ :type 'boolean
+ :group 'slime-ui)
+
+(defcustom slime-complete-symbol*-fancy nil
+ "Use information from argument lists for DWIM'ish symbol completion."
+ :group 'slime-mode
+ :type 'boolean)
+
+(defun slime-complete-symbol* ()
+ "Expand abbreviations and complete the symbol at point."
+ ;; NB: It is only the name part of the symbol that we actually want
+ ;; to complete -- the package prefix, if given, is just context.
+ (or (slime-maybe-complete-as-filename)
+ (slime-expand-abbreviations-and-complete)))
+
+;; FIXME: factorize
+(defun slime-expand-abbreviations-and-complete ()
+ (let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
+ (beg (move-marker (make-marker) (slime-symbol-start-pos)))
+ (prefix (buffer-substring-no-properties beg end))
+ (completion-result (slime-contextual-completions beg end))
+ (completion-set (first completion-result))
+ (completed-prefix (second completion-result)))
+ (if (null completion-set)
+ (progn (slime-minibuffer-respecting-message
+ "Can't find completion for \"%s\"" prefix)
+ (ding)
+ (slime-complete-restore-window-configuration))
+ ;; some XEmacs issue makes this distinction necessary
+ (cond ((> (length completed-prefix) (- end beg))
+ (goto-char end)
+ (insert-and-inherit completed-prefix)
+ (delete-region beg end)
+ (goto-char (+ beg (length completed-prefix))))
+ (t nil))
+ (cond ((and (member completed-prefix completion-set)
+ (slime-length= completion-set 1))
+ (slime-minibuffer-respecting-message "Sole completion")
+ (when slime-complete-symbol*-fancy
+ (slime-complete-symbol*-fancy-bit))
+ (slime-complete-restore-window-configuration))
+ ;; Incomplete
+ (t
+ (when (member completed-prefix completion-set)
+ (slime-minibuffer-respecting-message
+ "Complete but not unique"))
+ (when slime-c-p-c-unambiguous-prefix-p
+ (let ((unambiguous-completion-length
+ (loop for c in completion-set
+ minimizing (or (mismatch completed-prefix c)
+ (length completed-prefix)))))
+ (goto-char (+ beg unambiguous-completion-length))))
+ (slime-display-or-scroll-completions completion-set
+ completed-prefix))))))
+
+(defun slime-complete-symbol*-fancy-bit ()
+ "Do fancy tricks after completing a symbol.
+\(Insert a space or close-paren based on arglist information.)"
+ (let ((arglist (slime-get-arglist (slime-symbol-name-at-point))))
+ (when arglist
+ (let ((args
+ ;; Don't intern these symbols
+ (let ((obarray (make-vector 10 0)))
+ (cdr (read arglist))))
+ (function-call-position-p
+ (save-excursion
+ (backward-sexp)
+ (equal (char-before) ?\())))
+ (when function-call-position-p
+ (if (null args)
+ (insert-and-inherit ")")
+ (insert-and-inherit " ")
+ (when (and slime-space-information-p
+ (slime-background-activities-enabled-p)
+ (not (minibuffer-window-active-p (minibuffer-window))))
+ (slime-echo-arglist))))))))
+
+(defun slime-get-arglist (symbol-name)
+ "Return the argument list for SYMBOL-NAME."
+ (slime-eval `(swank:arglist-for-echo-area (quote (,symbol-name)))))
+
+(defun* slime-contextual-completions (beg end)
+ "Return a list of completions of the token from BEG to END in the
+current buffer."
+ (let ((token (buffer-substring-no-properties beg end)))
+ (cond
+ ((and (< beg (point-max))
+ (string= (buffer-substring-no-properties beg (1+ beg)) ":"))
+ ;; Contextual keyword completion
+ (multiple-value-bind (operator-names arg-indices points)
+ (save-excursion
+ (goto-char beg)
+ (slime-enclosing-form-specs))
+ (when operator-names
+ (let ((completions
+ (slime-completions-for-keyword operator-names token
+ arg-indices)))
+ (when (first completions)
+ (return-from slime-contextual-completions completions))
+ ;; If no matching keyword was found, do regular symbol
+ ;; completion.
+ ))))
+ ((and (> beg 2)
+ (string= (buffer-substring-no-properties (- beg 2) beg) "#\\"))
+ ;; Character name completion
+ (return-from slime-contextual-completions
+ (slime-completions-for-character token))))
+ ;; Regular symbol completion
+ (slime-completions token)))
+
+(defun slime-completions (prefix)
+ (slime-eval `(swank:completions ,prefix ',(slime-current-package))))
+
+(defun slime-completions-for-keyword (operator-designator prefix
+ arg-indices)
+ (slime-eval `(swank:completions-for-keyword ',operator-designator
+ ,prefix
+ ',arg-indices)))
+
+(defun slime-completions-for-character (prefix)
+ (slime-eval `(swank:completions-for-character ,prefix)))
+
+
+;;; Complete form
+
+(defun slime-complete-form ()
+ "Complete the form at point.
+This is a superset of the functionality of `slime-insert-arglist'."
+ (interactive)
+ ;; Find the (possibly incomplete) form around point.
+ (let ((form-string (slime-incomplete-form-at-point)))
+ (let ((result (slime-eval `(swank:complete-form ',form-string))))
+ (if (eq result :not-available)
+ (error "Could not generate completion for the form `%s'" form-string)
+ (progn
+ (just-one-space)
+ (save-excursion
+ ;; SWANK:COMPLETE-FORM always returns a closing
+ ;; parenthesis; but we only want to insert one if it's
+ ;; really necessary (thinking especially of paredit.el.)
+ (insert (substring result 0 -1))
+ (let ((slime-close-parens-limit 1))
+ (slime-close-all-parens-in-sexp)))
+ (save-excursion
+ (backward-up-list 1)
+ (indent-sexp)))))))
+
+;;; Initialization
+
+(defvar slime-c-p-c-init-undo-stack nil)
+
+(defun slime-c-p-c-init ()
+ ;; save current state for unload
+ (push
+ `(progn
+ (setq slime-complete-symbol-function ',slime-complete-symbol-function)
+ (remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect)
+ (define-key slime-mode-map "\C-c\C-s"
+ ',(lookup-key slime-mode-map "\C-c\C-s"))
+ (define-key slime-repl-mode-map "\C-c\C-s"
+ ',(lookup-key slime-repl-mode-map "\C-c\C-s")))
+ slime-c-p-c-init-undo-stack)
+ (setq slime-complete-symbol-function 'slime-complete-symbol*)
+ (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect)
+ (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form)
+ (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form))
+
+(defun slime-c-p-c-on-connect ()
+ (slime-eval-async '(swank:swank-require :swank-arglists)))
+
+(defun slime-c-p-c-unload ()
+ (while slime-c-p-c-init-undo-stack
+ (eval (pop slime-c-p-c-init-undo-stack))))
+
+(provide 'slime-c-p-c)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-editing-commands.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-editing-commands.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,189 @@
+;;; slime-editing-commands.el -- editing commands whithout server interaction
+;;
+;; Authors: Thomas F. Burdick <tfb(a)OCF.Berkeley.EDU>
+;; Luke Gorrie <luke(a)synap.se>
+;; Bill Clementson <billclem(a)gmail.com>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; and others
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation
+;;
+;; Add something like this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-editing-commands)))
+;;
+
+(defun slime-beginning-of-defun ()
+ (interactive)
+ (if (and (boundp 'slime-repl-input-start-mark)
+ slime-repl-input-start-mark)
+ (slime-repl-beginning-of-defun)
+ (beginning-of-defun)))
+
+(defun slime-end-of-defun ()
+ (interactive)
+ (if (and (boundp 'slime-repl-input-end-mark)
+ slime-repl-input-end-mark)
+ (slime-repl-end-of-defun)
+ (end-of-defun)))
+
+(defvar slime-comment-start-regexp
+ "\\(\\(^\\|[^\n\\\\]\\)\\([\\\\][\\\\]\\)*\\);+[ \t]*"
+ "Regexp to match the start of a comment.")
+
+(defun slime-beginning-of-comment ()
+ "Move point to beginning of comment.
+If point is inside a comment move to beginning of comment and return point.
+Otherwise leave point unchanged and return NIL."
+ (let ((boundary (point)))
+ (beginning-of-line)
+ (cond ((re-search-forward slime-comment-start-regexp boundary t)
+ (point))
+ (t (goto-char boundary)
+ nil))))
+
+(defun slime-close-all-parens-in-sexp (&optional region)
+ "Balance parentheses of open s-expressions at point.
+Insert enough right parentheses to balance unmatched left parentheses.
+Delete extra left parentheses. Reformat trailing parentheses
+Lisp-stylishly.
+
+If REGION is true, operate on the region. Otherwise operate on
+the top-level sexp before point."
+ (interactive "P")
+ (let ((sexp-level 0)
+ point)
+ (save-excursion
+ (save-restriction
+ (when region
+ (narrow-to-region (region-beginning) (region-end))
+ (goto-char (point-max)))
+ ;; skip over closing parens, but not into comment
+ (skip-chars-backward ") \t\n")
+ (when (slime-beginning-of-comment)
+ (forward-line)
+ (skip-chars-forward " \t"))
+ (setq point (point))
+ ;; count sexps until either '(' or comment is found at first column
+ (while (and (not (looking-at "^[(;]"))
+ (ignore-errors (backward-up-list 1) t))
+ (incf sexp-level))))
+ (when (> sexp-level 0)
+ ;; insert correct number of right parens
+ (goto-char point)
+ (dotimes (i sexp-level) (insert ")"))
+ ;; delete extra right parens
+ (setq point (point))
+ (skip-chars-forward " \t\n)")
+ (skip-chars-backward " \t\n")
+ (let* ((deleted-region (slime-delete-and-extract-region point (point)))
+ (deleted-text (substring-no-properties deleted-region))
+ (prior-parens-count (count ?\) deleted-text)))
+ ;; Remember: we always insert as many parentheses as necessary
+ ;; and only afterwards delete the superfluously-added parens.
+ (when slime-close-parens-limit
+ (let ((missing-parens (- sexp-level prior-parens-count
+ slime-close-parens-limit)))
+ (dotimes (i (max 0 missing-parens))
+ (delete-char -1))))))))
+
+(defvar slime-close-parens-limit nil
+ "Maxmimum parens for `slime-close-all-sexp' to insert. NIL
+means to insert as many parentheses as necessary to correctly
+close the form.")
+
+(defun slime-insert-balanced-comments (arg)
+ "Insert a set of balanced comments around the s-expression
+containing the point. If this command is invoked repeatedly
+\(without any other command occurring between invocations), the
+comment progressively moves outward over enclosing expressions.
+If invoked with a positive prefix argument, the s-expression arg
+expressions out is enclosed in a set of balanced comments."
+ (interactive "*p")
+ (save-excursion
+ (when (eq last-command this-command)
+ (when (search-backward "#|" nil t)
+ (save-excursion
+ (delete-char 2)
+ (while (and (< (point) (point-max)) (not (looking-at " *|#")))
+ (forward-sexp))
+ (replace-match ""))))
+ (while (> arg 0)
+ (backward-char 1)
+ (cond ((looking-at ")") (incf arg))
+ ((looking-at "(") (decf arg))))
+ (insert "#|")
+ (forward-sexp)
+ (insert "|#")))
+
+(defun slime-remove-balanced-comments ()
+ "Remove a set of balanced comments enclosing point."
+ (interactive "*")
+ (save-excursion
+ (when (search-backward "#|" nil t)
+ (delete-char 2)
+ (while (and (< (point) (point-max)) (not (looking-at " *|#")))
+ (forward-sexp))
+ (replace-match ""))))
+
+
+;; SLIME-CLOSE-PARENS-AT-POINT is obsolete:
+
+;; It doesn't work correctly on the REPL, because there
+;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to
+;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and
+;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the
+;; way how they're expect to work (i.e. END-OF-DEFUN does not signal
+;; an UNBOUND-PARENTHESES error.)
+
+;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead.
+
+;; (defun slime-close-parens-at-point ()
+;; "Close parenthesis at point to complete the top-level-form. Simply
+;; inserts ')' characters at point until `beginning-of-defun' and
+;; `end-of-defun' execute without errors, or `slime-close-parens-limit'
+;; is exceeded."
+;; (interactive)
+;; (loop for i from 1 to slime-close-parens-limit
+;; until (save-excursion
+;; (slime-beginning-of-defun)
+;; (ignore-errors (slime-end-of-defun) t))
+;; do (insert ")")))
+
+(defun slime-reindent-defun (&optional force-text-fill)
+ "Reindent the current defun, or refill the current paragraph.
+If point is inside a comment block, the text around point will be
+treated as a paragraph and will be filled with `fill-paragraph'.
+Otherwise, it will be treated as Lisp code, and the current defun
+will be reindented. If the current defun has unbalanced parens,
+an attempt will be made to fix it before reindenting.
+
+When given a prefix argument, the text around point will always
+be treated as a paragraph. This is useful for filling docstrings."
+ (interactive "P")
+ (save-excursion
+ (if (or force-text-fill (slime-beginning-of-comment))
+ (fill-paragraph nil)
+ (let ((start (progn (unless (or (and (zerop (current-column))
+ (eq ?\( (char-after)))
+ (and slime-repl-input-start-mark
+ (slime-repl-at-prompt-start-p)))
+ (slime-beginning-of-defun))
+ (point)))
+ (end (ignore-errors (slime-end-of-defun) (point))))
+ (unless end
+ (forward-paragraph)
+ (slime-close-all-parens-in-sexp)
+ (slime-end-of-defun)
+ (setf end (point)))
+ (indent-region start end nil)))))
+
+(defun slime-editing-commands-init ()
+ (define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun)
+ (define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun)
+ (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun))
+
+(provide 'slime-editing-commands)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-fancy-inspector.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-fancy-inspector.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,28 @@
+;;; slime-fancy-inspector.el --- Fancy inspector for CLOS objects
+;;
+;; Author: Marco Baringer <mb(a)bese.it> and others
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy-inspector)))
+;; (add-hook 'slime-connected-hook 'slime-install-fancy-inspector)
+
+(defun slime-install-fancy-inspector ()
+ (slime-eval-async '(swank:swank-require :swank-fancy-inspector)
+ (lambda (_)
+ (slime-eval-async '(swank:fancy-inspector-init)))))
+
+(defun slime-deinstall-fancy-inspector ()
+ (slime-eval-async '(swank:fancy-inspector-unload)))
+
+(defun slime-fancy-inspector-init ()
+ (add-hook 'slime-connected-hook 'slime-install-fancy-inspector))
+
+(defun slime-fancy-inspector-unload ()
+ (remove-hook 'slime-connected-hook 'slime-install-fancy-inspector))
+
+(provide 'slime-fancy-inspector)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-fancy.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-fancy.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,74 @@
+;;; slime-fancy.el --- Load and init some fancy SLIME contribs
+;;
+;; Authors: Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy)))
+;;
+;; We load all SLIME contribs that are currently working,
+;; and which only "upgrade" the behavior of SLIME in some way.
+;; This includes:
+;; * Adding new commands, keybindings, menu items
+;; * Making things clickable that would otherwise be just plain text
+
+;; Better arglist display, can be turned off by customization.
+(require 'slime-autodoc)
+(slime-autodoc-init)
+
+;; Adds new commands and installs compound-prefix-completion as
+;; default completion command. Behaves similar to standard Emacs
+;; completion, unless dashes are present. --mkoeppe
+(require 'slime-c-p-c)
+(slime-c-p-c-init)
+
+;; Just adds commands. (Well, shadows commands in lisp-mode-map)
+(require 'slime-editing-commands)
+(slime-editing-commands-init)
+
+;; Makes the inspector fancier.
+(require 'slime-fancy-inspector)
+(slime-fancy-inspector-init)
+
+;; Just adds the command C-c M-i. We do not make fuzzy completion the
+;; default completion invoked by TAB. --mkoeppe
+(require 'slime-fuzzy)
+(slime-fuzzy-init)
+
+;; Do not activate slime-highlighting-edits by default, as it's easier
+;; to explictly activate it (if a user really wants it) than to explictly
+;; deactivate it once it got globally enabled. -TCR.
+(require 'slime-highlight-edits)
+;(slime-highlight-edits-init)
+
+;; Load slime-presentations even though they seem to be a
+;; controversial feature, as they can be easily turned off by
+;; customizing swank:*record-repl-results*. --mkoeppe
+(require 'slime-presentations)
+(slime-presentations-init)
+
+;;; Do not load slime-presentation-streams, as this is an experimental
+;;; feature that installs patches into some Lisps. --mkoeppe
+;;(require 'slime-presentation-streams)
+
+(require 'slime-scratch)
+(slime-scratch-init)
+
+;;; Do not load slime-typeout-frame, as simply loading causes display of a
+;;; typeout frame, which cannot be turned off. --mkoeppe
+;;(require 'slime-typeout-frame)
+
+;; Just adds commands.
+(when (locate-library "tree-widget")
+ (require 'slime-xref-browser))
+
+;; Puts clickable references to documentation into SBCL errors.
+(require 'slime-references)
+(slime-references-init)
+
+(provide 'slime-fancy)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-fuzzy.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-fuzzy.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,596 @@
+;;; slime-fuzzy.el --- fuzzy symbol completion
+;;
+;; Authors: Brian Downing <bdowning(a)lavos.net>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; Attila Lendvai <attila.lendvai(a)gmail.com>
+;; and others
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-fuzzy)))
+;;
+
+
+;;; Code
+
+(defcustom slime-fuzzy-completion-in-place t
+ "When non-NIL the fuzzy symbol completion is done in place as
+opposed to moving the point to the completion buffer."
+ :group 'slime-mode
+ :type 'boolean)
+
+(defcustom slime-fuzzy-completion-limit 300
+ "Only return and present this many symbols from swank."
+ :group 'slime-mode
+ :type 'integer)
+
+(defcustom slime-fuzzy-completion-time-limit-in-msec 1500
+ "Limit the time spent (given in msec) in swank while gathering
+comletitions."
+ :group 'slime-mode
+ :type 'integer)
+
+(defvar slime-fuzzy-target-buffer nil
+ "The buffer that is the target of the completion activities.")
+(defvar slime-fuzzy-saved-window-configuration nil
+ "The saved window configuration before the fuzzy completion
+buffer popped up.")
+(defvar slime-fuzzy-start nil
+ "The beginning of the completion slot in the target buffer.
+This is a non-advancing marker.")
+(defvar slime-fuzzy-end nil
+ "The end of the completion slot in the target buffer.
+This is an advancing marker.")
+(defvar slime-fuzzy-original-text nil
+ "The original text that was in the completion slot in the
+target buffer. This is what is put back if completion is
+aborted.")
+(defvar slime-fuzzy-text nil
+ "The text that is currently in the completion slot in the
+target buffer. If this ever doesn't match, the target buffer has
+been modified and we abort without touching it.")
+(defvar slime-fuzzy-first nil
+ "The position of the first completion in the completions buffer.
+The descriptive text and headers are above this.")
+(defvar slime-fuzzy-last nil
+ "The position of the last completion in the completions buffer.
+If the time limit has exhausted during generation possible completion
+choices inside SWANK, an indication is printed below this.")
+(defvar slime-fuzzy-current-completion nil
+ "The current completion object. If this is the same before and
+after point moves in the completions buffer, the text is not
+replaced in the target for efficiency.")
+(defvar slime-fuzzy-current-completion-overlay nil
+ "The overlay representing the current completion in the completion
+buffer. This is used to hightlight the text.")
+
+;;;;;;; slime-target-buffer-fuzzy-completions-mode
+;; NOTE: this mode has to be able to override key mappings in slime-mode
+
+;; FIXME: clean this up
+
+(defun mimic-key-bindings (from-keymap to-keymap bindings-or-operation operation)
+ "Iterate on BINDINGS-OR-OPERATION. If an element is a symbol then
+try to look it up (as an operation) in FROM-KEYMAP. Non symbols are taken
+as default key bindings when none to be mimiced was found in FROM-KEYMAP.
+Set the resulting list of keys in TO-KEYMAP to OPERATION."
+ (let ((mimic-keys nil)
+ (direct-keys nil))
+ (dolist (key-or-operation bindings-or-operation)
+ (if (symbolp key-or-operation)
+ (setf mimic-keys (append mimic-keys (where-is-internal key-or-operation from-keymap nil t)))
+ (push key-or-operation direct-keys)))
+ (dolist (key (or mimic-keys direct-keys))
+ (define-key to-keymap key operation))))
+
+(defvar slime-target-buffer-fuzzy-completions-map
+ (let* ((map (make-sparse-keymap)))
+ (flet ((remap (keys to)
+ (mimic-key-bindings global-map map keys to)))
+
+ (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort)
+
+ (remap (list 'slime-fuzzy-indent-and-complete-symbol
+ 'slime-indent-and-complete-symbol
+ (kbd "<tab>"))
+ 'slime-fuzzy-select-or-update-completions)
+ (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev)
+ (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next)
+ (remap (list 'isearch-forward (kbd "C-s"))
+ (lambda ()
+ (interactive)
+ (select-window (get-buffer-window (slime-get-fuzzy-buffer)))
+ (call-interactively 'isearch-forward)))
+
+ ;; some unconditional direct bindings
+ (dolist (key (list (kbd "<return>") (kbd "RET") (kbd "<SPC>") "(" ")" "[" "]"))
+ (define-key map key 'slime-fuzzy-select-and-process-event-in-target-buffer)))
+ map
+ )
+ "Keymap for slime-target-buffer-fuzzy-completions-mode. This will override the key
+bindings in the target buffer temporarily during completion.")
+
+;; Make sure slime-fuzzy-target-buffer-completions-mode's map is
+;; before everything else.
+(setf minor-mode-map-alist
+ (stable-sort minor-mode-map-alist
+ (lambda (a b)
+ (eq a 'slime-fuzzy-target-buffer-completions-mode))
+ :key #'car))
+
+
+(define-minor-mode slime-fuzzy-target-buffer-completions-mode
+ "This minor mode is intented to override key bindings during fuzzy
+completions in the target buffer. Most of the bindings will do an implicit select
+in the completion window and let the keypress be processed in the target buffer."
+ nil
+ nil
+ slime-target-buffer-fuzzy-completions-map)
+
+(add-to-list 'minor-mode-alist
+ '(slime-fuzzy-target-buffer-completions-mode
+ " Fuzzy Target Buffer Completions"))
+
+(define-derived-mode slime-fuzzy-completions-mode
+ fundamental-mode "Fuzzy Completions"
+ "Major mode for presenting fuzzy completion results.
+
+When you run `slime-fuzzy-complete-symbol', the symbol token at
+point is completed using the Fuzzy Completion algorithm; this
+means that the token is taken as a sequence of characters and all
+the various possibilities that this sequence could meaningfully
+represent are offered as selectable choices, sorted by how well
+they deem to be a match for the token. (For instance, the first
+choice of completing on \"mvb\" would be \"multiple-value-bind\".)
+
+Therefore, a new buffer (*Fuzzy Completions*) will pop up that
+contains the different completion choices. Simultaneously, a
+special minor-mode will be temporarily enabled in the original
+buffer where you initiated fuzzy completion (also called the
+``target buffer'') in order to navigate through the *Fuzzy
+Completions* buffer without leaving.
+
+With focus in *Fuzzy Completions*:
+ Type `n' and `p' (`UP', `DOWN') to navigate between completions.
+ Type `RET' or `TAB' to select the completion near point.
+ Type `q' to abort.
+
+With focus in the target buffer:
+ Type `UP' and `DOWN' to navigate between completions.
+ Type a character that does not constitute a symbol name
+ to insert the current choice and then that character (`(', `)',
+ `SPACE', `RET'.) Use `TAB' to simply insert the current choice.
+ Use C-g to abort.
+
+Alternatively, you can click <mouse-2> on a completion to select it.
+
+
+Complete listing of keybindings within the target buffer:
+
+\\<slime-target-buffer-fuzzy-completions-map>\
+\\{slime-target-buffer-fuzzy-completions-map}
+
+Complete listing of keybindings with *Fuzzy Completions*:
+
+\\<slime-fuzzy-completions-map>\
+\\{slime-fuzzy-completions-map}"
+ (use-local-map slime-fuzzy-completions-map))
+
+(defvar slime-fuzzy-completions-map
+ (let* ((map (make-sparse-keymap)))
+ (flet ((remap (keys to)
+ (mimic-key-bindings global-map map keys to)))
+ (remap (list 'keyboard-quit (kbd "C-g")) 'slime-fuzzy-abort)
+ (define-key map "q" 'slime-fuzzy-abort)
+
+ (remap (list 'previous-line (kbd "<up>")) 'slime-fuzzy-prev)
+ (remap (list 'next-line (kbd "<down>")) 'slime-fuzzy-next)
+
+ (define-key map "n" 'slime-fuzzy-next)
+ (define-key map "\M-n" 'slime-fuzzy-next)
+
+ (define-key map "p" 'slime-fuzzy-prev)
+ (define-key map "\M-p" 'slime-fuzzy-prev)
+
+ (define-key map "\d" 'scroll-down)
+
+ (remap (list 'slime-fuzzy-indent-and-complete-symbol
+ 'slime-indent-and-complete-symbol
+ (kbd "<tab>"))
+ 'slime-fuzzy-select)
+
+ (define-key map (kbd "<mouse-2>") 'slime-fuzzy-select/mouse))
+
+ (define-key map (kbd "RET") 'slime-fuzzy-select)
+ (define-key map (kbd "<SPC>") 'slime-fuzzy-select)
+
+ map)
+ "Keymap for slime-fuzzy-completions-mode when in the completion buffer.")
+
+(defun slime-fuzzy-completions (prefix &optional default-package)
+ "Get the list of sorted completion objects from completing
+`prefix' in `package' from the connected Lisp."
+ (let ((prefix (etypecase prefix
+ (symbol (symbol-name prefix))
+ (string prefix))))
+ (slime-eval `(swank:fuzzy-completions ,prefix
+ ,(or default-package
+ (slime-find-buffer-package)
+ (slime-current-package))
+ :limit ,slime-fuzzy-completion-limit
+ :time-limit-in-msec ,slime-fuzzy-completion-time-limit-in-msec))))
+
+(defun slime-fuzzy-selected (prefix completion)
+ "Tell the connected Lisp that the user selected completion
+`completion' as the completion for `prefix'."
+ (let ((no-properties (copy-sequence prefix)))
+ (set-text-properties 0 (length no-properties) nil no-properties)
+ (slime-eval `(swank:fuzzy-completion-selected ,no-properties
+ ',completion))))
+
+(defun slime-fuzzy-indent-and-complete-symbol ()
+ "Indent the current line and perform fuzzy symbol completion. First
+indent the line. If indenting doesn't move point, complete the
+symbol. If there's no symbol at the point, show the arglist for the
+most recently enclosed macro or function."
+ (interactive)
+ (let ((pos (point)))
+ (unless (get-text-property (line-beginning-position) 'slime-repl-prompt)
+ (lisp-indent-line))
+ (when (= pos (point))
+ (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
+ (slime-fuzzy-complete-symbol))
+ ((memq (char-before) '(?\t ?\ ))
+ (slime-echo-arglist))))))
+
+(defun* slime-fuzzy-complete-symbol ()
+ "Fuzzily completes the abbreviation at point into a symbol."
+ (interactive)
+ (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
+ (return-from slime-fuzzy-complete-symbol
+ (if slime-when-complete-filename-expand
+ (comint-replace-by-expanded-filename)
+ (comint-dynamic-complete-as-filename))))
+ (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)))
+ (destructuring-bind (completion-set interrupted-p)
+ (slime-fuzzy-completions prefix)
+ (if (null completion-set)
+ (progn (slime-minibuffer-respecting-message
+ "Can't find completion for \"%s\"" prefix)
+ (ding)
+ (slime-fuzzy-done))
+ (goto-char end)
+ (cond ((slime-length= completion-set 1)
+ (insert-and-inherit (caar completion-set)) ; insert completed string
+ (delete-region beg end)
+ (goto-char (+ beg (length (caar completion-set))))
+ (slime-minibuffer-respecting-message "Sole completion")
+ (slime-fuzzy-done))
+ ;; Incomplete
+ (t
+ (slime-minibuffer-respecting-message "Complete but not unique")
+ (slime-fuzzy-choices-buffer completion-set interrupted-p beg end)))))))
+
+
+(defun slime-get-fuzzy-buffer ()
+ (get-buffer-create "*Fuzzy Completions*"))
+
+(defvar slime-fuzzy-explanation
+ "For help on how the use this buffer, see `slime-fuzzy-completions-mode'.
+
+Flags: boundp fboundp generic-function class macro special-operator package
+\n"
+ "The explanation that gets inserted at the beginning of the
+*Fuzzy Completions* buffer.")
+
+(defun slime-fuzzy-insert-completion-choice (completion max-length)
+ "Inserts the completion object `completion' as a formatted
+completion choice into the current buffer, and mark it with the
+proper text properties."
+ (let ((start (point))
+ (symbol-name (first completion))
+ (score (second completion))
+ (chunks (third completion))
+ (flags (fourth completion)))
+ (insert symbol-name)
+ (let ((end (point)))
+ (dolist (chunk chunks)
+ (put-text-property (+ start (first chunk))
+ (+ start (first chunk)
+ (length (second chunk)))
+ 'face 'bold))
+ (put-text-property start (point) 'mouse-face 'highlight)
+ (dotimes (i (- max-length (- end start)))
+ (insert " "))
+ (insert (format " %s%s%s%s%s%s%s %8.2f"
+ (if (member :boundp flags) "b" "-")
+ (if (member :fboundp flags) "f" "-")
+ (if (member :generic-function flags) "g" "-")
+ (if (member :class flags) "c" "-")
+ (if (member :macro flags) "m" "-")
+ (if (member :special-operator flags) "s" "-")
+ (if (member :package flags) "p" "-")
+ score))
+ (insert "\n")
+ (put-text-property start (point) 'completion completion))))
+
+(defun slime-fuzzy-insert (text)
+ "Inserts `text' into the target buffer in the completion slot.
+If the buffer has been modified in the meantime, abort the
+completion process. Otherwise, update all completion variables
+so that the new text is present."
+ (with-current-buffer slime-fuzzy-target-buffer
+ (cond
+ ((not (string-equal slime-fuzzy-text
+ (buffer-substring slime-fuzzy-start
+ slime-fuzzy-end)))
+ (slime-fuzzy-done)
+ (beep)
+ (message "Target buffer has been modified!"))
+ (t
+ (goto-char slime-fuzzy-start)
+ (delete-region slime-fuzzy-start slime-fuzzy-end)
+ (insert-and-inherit text)
+ (setq slime-fuzzy-text text)
+ (goto-char slime-fuzzy-end)))))
+
+(defun slime-fuzzy-choices-buffer (completions interrupted-p start end)
+ "Creates (if neccessary), populates, and pops up the *Fuzzy
+Completions* buffer with the completions from `completions' and
+the completion slot in the current buffer bounded by `start' and
+`end'. This saves the window configuration before popping the
+buffer so that it can possibly be restored when the user is
+done."
+ (let ((new-completion-buffer (not slime-fuzzy-target-buffer)))
+ (when new-completion-buffer
+ (setq slime-fuzzy-saved-window-configuration
+ (current-window-configuration)))
+ (slime-fuzzy-enable-target-buffer-completions-mode)
+ (setq slime-fuzzy-target-buffer (current-buffer))
+ (setq slime-fuzzy-start (move-marker (make-marker) start))
+ (setq slime-fuzzy-end (move-marker (make-marker) end))
+ (set-marker-insertion-type slime-fuzzy-end t)
+ (setq slime-fuzzy-original-text (buffer-substring start end))
+ (setq slime-fuzzy-text slime-fuzzy-original-text)
+ (slime-fuzzy-fill-completions-buffer completions interrupted-p)
+ (pop-to-buffer (slime-get-fuzzy-buffer))
+ (when new-completion-buffer
+ ;; Hook to nullify window-config restoration if the user changes
+ ;; the window configuration himself.
+ (when (boundp 'window-configuration-change-hook)
+ (add-hook 'window-configuration-change-hook
+ 'slime-fuzzy-window-configuration-change))
+ (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort)
+ (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
+ (when slime-fuzzy-completion-in-place
+ ;; switch back to the original buffer
+ (switch-to-buffer-other-window slime-fuzzy-target-buffer))))
+
+(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p)
+ "Erases and fills the completion buffer with the given completions."
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (slime-fuzzy-completions-mode)
+ (insert slime-fuzzy-explanation)
+ (let ((max-length 12))
+ (dolist (completion completions)
+ (setf max-length (max max-length (length (first completion)))))
+
+ (insert "Completion:")
+ (dotimes (i (- max-length 10)) (insert " "))
+ ;; Flags: Score:
+ ;; ... ------- --------
+ ;; bfgcmsp
+ (insert "Flags: Score:\n")
+ (dotimes (i max-length) (insert "-"))
+ (insert " ------- --------\n")
+ (setq slime-fuzzy-first (point))
+
+ (dolist (completion completions)
+ (setq slime-fuzzy-last (point)) ; will eventually become the last entry
+ (slime-fuzzy-insert-completion-choice completion max-length))
+
+ (when interrupted-p
+ (insert "...\n")
+ (insert "[Interrupted: time limit exhausted]"))
+
+ (setq buffer-read-only t))
+ (setq slime-fuzzy-current-completion
+ (caar completions))
+ (goto-char 0)
+ (slime-fuzzy-next)))
+
+(defun slime-fuzzy-enable-target-buffer-completions-mode ()
+ "Store the target buffer's local map, so that we can restore it."
+ (unless slime-fuzzy-target-buffer-completions-mode
+; (slime-log-event "Enabling target buffer completions mode")
+ (slime-fuzzy-target-buffer-completions-mode 1)))
+
+(defun slime-fuzzy-disable-target-buffer-completions-mode ()
+ "Restores the target buffer's local map when completion is finished."
+ (when slime-fuzzy-target-buffer-completions-mode
+; (slime-log-event "Disabling target buffer completions mode")
+ (slime-fuzzy-target-buffer-completions-mode 0)))
+
+(defun slime-fuzzy-insert-from-point ()
+ "Inserts the completion that is under point in the completions
+buffer into the target buffer. If the completion in question had
+already been inserted, it does nothing."
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (let ((current-completion (get-text-property (point) 'completion)))
+ (when (and current-completion
+ (not (eq slime-fuzzy-current-completion
+ current-completion)))
+ (slime-fuzzy-insert
+ (first (get-text-property (point) 'completion)))
+ (setq slime-fuzzy-current-completion
+ current-completion)))))
+
+(defun slime-fuzzy-post-command-hook ()
+ "The post-command-hook for the *Fuzzy Completions* buffer.
+This makes sure the completion slot in the target buffer matches
+the completion that point is on in the completions buffer."
+ (condition-case err
+ (when slime-fuzzy-target-buffer
+ (slime-fuzzy-insert-from-point))
+ (error
+ ;; Because this is called on the post-command-hook, we mustn't let
+ ;; errors propagate.
+ (message "Error in slime-fuzzy-post-command-hook: %S" err))))
+
+(defun slime-fuzzy-next ()
+ "Moves point directly to the next completion in the completions
+buffer."
+ (interactive)
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (slime-fuzzy-dehighlight-current-completion)
+ (let ((point (next-single-char-property-change (point) 'completion nil slime-fuzzy-last)))
+ (set-window-point (get-buffer-window (current-buffer)) point)
+ (goto-char point))
+ (slime-fuzzy-highlight-current-completion)))
+
+(defun slime-fuzzy-prev ()
+ "Moves point directly to the previous completion in the
+completions buffer."
+ (interactive)
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (slime-fuzzy-dehighlight-current-completion)
+ (let ((point (previous-single-char-property-change (point) 'completion nil slime-fuzzy-first)))
+ (set-window-point (get-buffer-window (current-buffer)) point)
+ (goto-char point))
+ (slime-fuzzy-highlight-current-completion)))
+
+(defun slime-fuzzy-dehighlight-current-completion ()
+ "Restores the original face for the current completion."
+ (when slime-fuzzy-current-completion-overlay
+ (overlay-put slime-fuzzy-current-completion-overlay 'face 'nil)))
+
+(defun slime-fuzzy-highlight-current-completion ()
+ "Highlights the current completion, so that the user can see it on the screen."
+ (let ((pos (point)))
+ (setq slime-fuzzy-current-completion-overlay
+ (make-overlay (point) (1- (search-forward " "))
+ (current-buffer) t nil))
+ (overlay-put slime-fuzzy-current-completion-overlay 'face 'secondary-selection)
+ (goto-char pos)))
+
+(defun slime-fuzzy-abort ()
+ "Aborts the completion process, setting the completions slot in
+the target buffer back to its original contents."
+ (interactive)
+ (when slime-fuzzy-target-buffer
+ (slime-fuzzy-done)))
+
+(defun slime-fuzzy-select ()
+ "Selects the current completion, making sure that it is inserted
+into the target buffer. This tells the connected Lisp what completion
+was selected."
+ (interactive)
+ (when slime-fuzzy-target-buffer
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (let ((completion (get-text-property (point) 'completion)))
+ (when completion
+ (slime-fuzzy-insert (first completion))
+ (slime-fuzzy-selected slime-fuzzy-original-text
+ completion)
+ (slime-fuzzy-done))))))
+
+(defun slime-fuzzy-select-or-update-completions ()
+ "If there were no changes since the last time fuzzy completion was started
+this function will select the current completion. Otherwise refreshes the completion
+list based on the changes made."
+ (interactive)
+; (slime-log-event "Selecting or updating completions")
+ (if (string-equal slime-fuzzy-original-text
+ (buffer-substring slime-fuzzy-start
+ slime-fuzzy-end))
+ (slime-fuzzy-select)
+ (slime-fuzzy-complete-symbol)))
+
+(defun slime-fuzzy-process-event-in-completions-buffer ()
+ "Simply processes the event in the target buffer"
+ (interactive)
+ (with-current-buffer (slime-get-fuzzy-buffer)
+ (push last-input-event unread-command-events)))
+
+(defun slime-fuzzy-select-and-process-event-in-target-buffer ()
+ "Selects the current completion, making sure that it is inserted
+into the target buffer and processes the event in the target buffer."
+ (interactive)
+; (slime-log-event "Selecting and processing event in target buffer")
+ (when slime-fuzzy-target-buffer
+ (let ((buff slime-fuzzy-target-buffer))
+ (slime-fuzzy-select)
+ (with-current-buffer buff
+ (slime-fuzzy-disable-target-buffer-completions-mode)
+ (push last-input-event unread-command-events)))))
+
+(defun slime-fuzzy-select/mouse (event)
+ "Handle a mouse-2 click on a completion choice as if point were
+on the completion choice and the slime-fuzzy-select command was
+run."
+ (interactive "e")
+ (with-current-buffer (window-buffer (posn-window (event-end event)))
+ (save-excursion
+ (goto-char (posn-point (event-end event)))
+ (when (get-text-property (point) 'mouse-face)
+ (slime-fuzzy-insert-from-point)
+ (slime-fuzzy-select)))))
+
+(defun slime-fuzzy-done ()
+ "Cleans up after the completion process. This removes all hooks,
+and attempts to restore the window configuration. If this fails,
+it just burys the completions buffer and leaves the window
+configuration alone."
+ (when slime-fuzzy-target-buffer
+ (set-buffer slime-fuzzy-target-buffer)
+ (slime-fuzzy-disable-target-buffer-completions-mode)
+ (if (slime-fuzzy-maybe-restore-window-configuration)
+ (bury-buffer (slime-get-fuzzy-buffer))
+ ;; We couldn't restore the windows, so just bury the fuzzy
+ ;; completions buffer and let something else fill it in.
+ (pop-to-buffer (slime-get-fuzzy-buffer))
+ (bury-buffer))
+ (pop-to-buffer slime-fuzzy-target-buffer)
+ (goto-char slime-fuzzy-end)
+ (setq slime-fuzzy-target-buffer nil)
+ (remove-hook 'window-configuration-change-hook
+ 'slime-fuzzy-window-configuration-change)))
+
+(defun slime-fuzzy-maybe-restore-window-configuration ()
+ "Restores the saved window configuration if it has not been
+nullified."
+ (when (boundp 'window-configuration-change-hook)
+ (remove-hook 'window-configuration-change-hook
+ 'slime-fuzzy-window-configuration-change))
+ (if (not slime-fuzzy-saved-window-configuration)
+ nil
+ (set-window-configuration slime-fuzzy-saved-window-configuration)
+ (setq slime-fuzzy-saved-window-configuration nil)
+ t))
+
+(defun slime-fuzzy-window-configuration-change ()
+ "Called on window-configuration-change-hook. Since the window
+configuration was changed, we nullify our saved configuration."
+ (setq slime-fuzzy-saved-window-configuration nil))
+
+;;; Initialization
+
+(defun slime-fuzzy-init ()
+ (slime-fuzzy-bind-keys))
+
+(defun slime-fuzzy-bind-keys ()
+ (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)
+ (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol))
+
+(slime-require :swank-fuzzy)
+
+(provide 'slime-fuzzy)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-highlight-edits.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-highlight-edits.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,99 @@
+;;; slime-higlight-edits --- highlight edited, i.e. not yet compiled, code
+;;
+;; Author: William Bland <doctorbill.news(a)gmail.com> and others
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this your .emacs:
+;;
+;; (add-to-list 'load-path "<contrib-dir>")
+;; (autoload 'slime-highlight-edits-mode "slime-highlight-edits")
+;; (add-hook 'slime-mode-hook (lambda () (slime-highlight-edits-mode 1)))
+
+(defface slime-highlight-edits-face
+ `((((class color) (background light))
+ (:background "lightgray"))
+ (((class color) (background dark))
+ (:background "dimgray"))
+ (t (:background "yellow")))
+ "Face for displaying edit but not compiled code."
+ :group 'slime-mode-faces)
+
+(define-minor-mode slime-highlight-edits-mode
+ "Minor mode to highlight not-yet-compiled code." nil)
+
+(add-hook 'slime-highlight-edits-mode-on-hook
+ 'slime-highlight-edits-init-buffer)
+
+(add-hook 'slime-highlight-edits-mode-off-hook
+ 'slime-highlight-edits-reset-buffer)
+
+(defun slime-highlight-edits-init-buffer ()
+ (make-local-variable 'after-change-functions)
+ (add-to-list 'after-change-functions
+ 'slime-highlight-edits)
+ (add-to-list 'slime-before-compile-functions
+ 'slime-highlight-edits-compile-hook))
+
+(defun slime-highlight-edits-reset-buffer ()
+ (setq after-change-functions
+ (remove 'slime-highlight-edits after-change-functions))
+ (slime-remove-edits (point-min) (point-max)))
+
+;; FIXME: what's the LEN arg for?
+(defun slime-highlight-edits (beg end &optional len)
+ (save-match-data
+ (when (and (slime-connected-p)
+ (not (slime-inside-comment-p beg end))
+ (not (slime-only-whitespace-p beg end)))
+ (let ((overlay (make-overlay beg end)))
+ (overlay-put overlay 'face 'slime-highlight-edits-face)
+ (overlay-put overlay 'slime-edit t)))))
+
+(defun slime-remove-edits (start end)
+ "Delete the existing Slime edit hilights in the current buffer."
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (dolist (o (overlays-at (point)))
+ (when (overlay-get o 'slime-edit)
+ (delete-overlay o)))
+ (goto-char (next-overlay-change (point))))))
+
+(defun slime-highlight-edits-compile-hook (start end)
+ (when slime-highlight-edits-mode
+ (let ((start (save-excursion (goto-char start)
+ (skip-chars-backward " \t\n\r")
+ (point)))
+ (end (save-excursion (goto-char end)
+ (skip-chars-forward " \t\n\r")
+ (point))))
+ (slime-remove-edits start end))))
+
+(defun slime-inside-comment-p (beg end)
+ "Is the region from BEG to END in a comment?"
+ (save-excursion
+ (goto-char beg)
+ (let* ((hs-c-start-regexp ";\\|#|")
+ (comment (hs-inside-comment-p)))
+ (and comment
+ (destructuring-bind (cbeg cend) comment
+ (<= end cend))))))
+
+(defun slime-only-whitespace-p (beg end)
+ "Contains the region from BEG to END only whitespace?"
+ (save-excursion
+ (goto-char beg)
+ (skip-chars-forward " \n\t\r" end)
+ (<= end (point))))
+
+(defun slime-highlight-edits-mode-on () (slime-highlight-edits-mode 1))
+
+(defun slime-highlight-edits-init ()
+ (add-hook 'slime-mode-hook 'slime-highlight-edits-mode-on))
+
+(defun slime-highlight-edits-unload ()
+ (remove-hook 'slime-mode-hook 'slime-highlight-edits-mode-on))
+
+(provide 'slime-highlight-edits)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-parse.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-parse.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,382 @@
+;;; slime-parse.el --- parsing of Common Lisp source code
+;;
+;; Authors: Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; and others
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+
+(defun slime-incomplete-form-at-point ()
+ "Looks for a ``raw form spec'' around point to be processed by
+SWANK::PARSE-FORM-SPEC. It is similiar to
+SLIME-INCOMPLETE-SEXP-AT-POINT but looks further back than just
+one sexp to find out the context."
+ (multiple-value-bind (operators arg-indices points)
+ (slime-enclosing-form-specs)
+ (if (null operators)
+ ""
+ (let ((op (first operators))
+ (op-start (first points))
+ (arg-index (first arg-indices)))
+ (destructure-case (slime-ensure-list op)
+ ((:declaration declspec) op)
+ ((:type-specifier typespec) op)
+ (t
+ (slime-make-form-spec-from-string
+ (concat (slime-incomplete-sexp-at-point) ")"))))))))
+
+;; XXX: unused function
+(defun slime-cl-symbol-external-ref-p (symbol)
+ "Does SYMBOL refer to an external symbol?
+FOO:BAR is an external reference.
+FOO::BAR is not, and nor is BAR."
+ (let ((name (if (stringp symbol) symbol (symbol-name symbol))))
+ (and (string-match ":" name)
+ (not (string-match "::" name)))))
+
+(defun slime-cl-symbol-name (symbol)
+ (let ((n (if (stringp symbol) symbol (symbol-name symbol))))
+ (if (string-match ":\\([^:]*\\)$" n)
+ (let ((symbol-part (match-string 1 n)))
+ (if (string-match "^|\\(.*\\)|$" symbol-part)
+ (match-string 1 symbol-part)
+ symbol-part))
+ n)))
+
+(defun slime-cl-symbol-package (symbol &optional default)
+ (let ((n (if (stringp symbol) symbol (symbol-name symbol))))
+ (if (string-match "^\\([^:]*\\):" n)
+ (match-string 1 n)
+ default)))
+
+;; XXX: unused function
+(defun slime-qualify-cl-symbol (symbol-or-name)
+ "Like `slime-qualify-cl-symbol-name', but interns the result."
+ (intern (slime-qualify-cl-symbol-name symbol-or-name)))
+
+(defun slime-qualify-cl-symbol-name (symbol-or-name)
+ "Return a package-qualified symbol-name that indicates the CL symbol
+SYMBOL. If SYMBOL doesn't already have a package prefix the current
+package is used."
+ (let ((s (if (stringp symbol-or-name)
+ symbol-or-name
+ (symbol-name symbol-or-name))))
+ (if (slime-cl-symbol-package s)
+ s
+ (format "%s::%s"
+ (let* ((package (slime-current-package)))
+ ;; package is a string like ":cl-user" or "CL-USER".
+ (if (and package (string-match "^:" package))
+ (substring package 1)
+ package))
+ (slime-cl-symbol-name s)))))
+
+
+(defun slime-parse-sexp-at-point (&optional n skip-blanks-p)
+ "Return the sexp at point as a string, otherwise nil.
+If N is given and greater than 1, a list of all such sexps
+following the sexp at point is returned. (If there are not
+as many sexps as N, a list with < N sexps is returned.)
+
+If SKIP-BLANKS-P is true, leading whitespaces &c are skipped.
+"
+ (interactive "p") (or n (setq n 1))
+ (flet ((sexp-at-point (first-choice)
+ (let ((string (if (eq first-choice :symbol-first)
+ (or (slime-symbol-name-at-point)
+ (thing-at-point 'sexp))
+ (or (thing-at-point 'sexp)
+ (slime-symbol-name-at-point)))))
+ (if string (substring-no-properties string) nil))))
+ ;; `thing-at-point' depends upon the current syntax table; otherwise
+ ;; keywords like `:foo' are not recognized as sexps. (This function
+ ;; may be called from temporary buffers etc.)
+ (with-syntax-table lisp-mode-syntax-table
+ (save-excursion
+ (when skip-blanks-p ; e.g. `( foo bat)' where point is after ?\(.
+ (slime-forward-blanks))
+ (let ((result nil))
+ (dotimes (i n)
+ ;; `foo(bar baz)' where point is at ?\( or ?\).
+ (if (and (char-after) (member (char-syntax (char-after)) '(?\( ?\) ?\')))
+ (push (sexp-at-point :sexp-first) result)
+ (push (sexp-at-point :symbol-first) result))
+ (ignore-errors (forward-sexp) (slime-forward-blanks))
+ (save-excursion
+ (unless (slime-point-moves-p (ignore-errors (forward-sexp)))
+ (return))))
+ (if (slime-length= result 1)
+ (first result)
+ (nreverse result)))))))
+
+(defun slime-incomplete-sexp-at-point (&optional n)
+ (interactive "p") (or n (setq n 1))
+ (buffer-substring-no-properties (save-excursion (backward-up-list n) (point))
+ (point)))
+
+
+(defun slime-parse-extended-operator-name (user-point forms indices points)
+ "Assume that point is directly at the operator that should be parsed.
+USER-POINT is the value of `point' where the user was looking at.
+OPS, INDICES and POINTS are updated to reflect the new values after
+parsing, and are then returned back as multiple values."
+ ;; OPS, INDICES and POINTS are like the finally returned values of
+ ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order,
+ ;; i.e. the leftmost (that is the latest) operator comes
+ ;; first.
+ (save-excursion
+ (ignore-errors
+ (let* ((current-op (first (first forms)))
+ (op-name (upcase (slime-cl-symbol-name current-op)))
+ (assoc (assoc op-name slime-extended-operator-name-parser-alist))
+ (entry (cdr assoc))
+ (parser (if (and entry (listp entry))
+ (apply (first entry) (rest entry))
+ entry)))
+ (ignore-errors
+ (forward-char (1+ (length current-op)))
+ (slime-forward-blanks))
+ (when parser
+ (multiple-value-setq (forms indices points)
+ (funcall parser op-name user-point forms indices points))))))
+ (values forms indices points))
+
+
+(defvar slime-extended-operator-name-parser-alist
+ '(("MAKE-INSTANCE" . (slime-make-extended-operator-parser/look-ahead 1))
+ ("MAKE-CONDITION" . (slime-make-extended-operator-parser/look-ahead 1))
+ ("ERROR" . (slime-make-extended-operator-parser/look-ahead 1))
+ ("SIGNAL" . (slime-make-extended-operator-parser/look-ahead 1))
+ ("WARN" . (slime-make-extended-operator-parser/look-ahead 1))
+ ("CERROR" . (slime-make-extended-operator-parser/look-ahead 2))
+ ("CHANGE-CLASS" . (slime-make-extended-operator-parser/look-ahead 2))
+ ("DEFMETHOD" . (slime-make-extended-operator-parser/look-ahead 1))
+ ("APPLY" . (slime-make-extended-operator-parser/look-ahead 1))
+ ("DECLARE" . slime-parse-extended-operator/declare)
+ ("DECLAIM" . slime-parse-extended-operator/declare)
+ ("PROCLAIM" . slime-parse-extended-operator/declare)))
+
+(defun slime-make-extended-operator-parser/look-ahead (steps)
+ "Returns a parser that parses the current operator at point
+plus STEPS-many additional sexps on the right side of the
+operator."
+ (lexical-let ((n steps))
+ #'(lambda (name user-point current-forms current-indices current-points)
+ (let ((old-forms (rest current-forms)))
+ (let* ((args (slime-ensure-list (slime-parse-sexp-at-point n)))
+ (arg-specs (mapcar #'slime-make-form-spec-from-string args)))
+ (setq current-forms (cons `(,name ,@arg-specs) old-forms))))
+ (values current-forms current-indices current-points)
+ )))
+
+(defun slime-parse-extended-operator/declare
+ (name user-point current-forms current-indices current-points)
+ (when (string= (thing-at-point 'char) "(")
+ (let ((orig-point (point)))
+ (goto-char user-point)
+ (slime-end-of-symbol)
+ ;; Head of CURRENT-FORMS is "declare" at this point, but we're
+ ;; interested in what comes next.
+ (let* ((decl-ops (rest current-forms))
+ (decl-indices (rest current-indices))
+ (decl-points (rest current-points))
+ (decl-pos (1- (first decl-points)))
+ (nesting (slime-nesting-until-point decl-pos))
+ (declspec-str (concat (slime-incomplete-sexp-at-point nesting)
+ (make-string nesting ?\)))))
+ (save-match-data ; `(declare ((foo ...))' or `(declare (type (foo ...)))' ?
+ (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$"
+ declspec-str))
+ (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$"
+ declspec-str)))
+ (let* ((typespec-str (match-string 1 declspec-str))
+ (typespec (slime-make-form-spec-from-string typespec-str)))
+ (setq current-forms (list `(:type-specifier ,typespec)))
+ (setq current-indices (list (second decl-indices)))
+ (setq current-points (list (second decl-points))))
+ (let ((declspec (slime-make-form-spec-from-string declspec-str)))
+ (setq current-forms (list `(,name) `(:declaration ,declspec)))
+ (setq current-indices (list (first current-indices)
+ (first decl-indices)))
+ (setq current-points (list (first current-points)
+ (first decl-points)))))))))
+ (values current-forms current-indices current-points))
+
+(defun slime-nesting-until-point (target-point)
+ "Returns the nesting level between current point and TARGET-POINT.
+If TARGET-POINT could not be reached, 0 is returned. (As a result
+TARGET-POINT should always be placed just before a `?\('.)"
+ (save-excursion
+ (let ((nesting 0))
+ (while (> (point) target-point)
+ (backward-up-list)
+ (incf nesting))
+ (if (= (point) target-point)
+ nesting
+ 0))))
+
+(defun slime-make-form-spec-from-string (string &optional strip-operator-p)
+ "If STRIP-OPERATOR-P is T and STRING is the string
+representation of a form, the string representation of this form
+is stripped from the form. This can be important to avoid mutual
+recursion between this function, `slime-enclosing-form-specs' and
+`slime-parse-extended-operator-name'.
+
+Examples:
+
+ \"(foo (bar 1 (baz :quux)) 'toto)\"
+
+ => (\"foo\" (\"bar\" \"1\" (\"baz\" \":quux\")) \"'toto\")
+"
+ (cond ((slime-length= string 0) "") ; ""
+ ((equal string "()") '()) ; "()"
+ ((eql (char-syntax (aref string 0)) ?\') string) ; "'(foo)", "#(foo)" &c
+ ((not (eql (aref string 0) ?\()) string) ; "foo"
+ (t ; "(op arg1 arg2 ...)"
+ (with-temp-buffer
+ ;; Do NEVER ever try to activate `lisp-mode' here with
+ ;; `slime-use-autodoc-mode' enabled, as this function is used
+ ;; to compute the current autodoc itself.
+ (erase-buffer)
+ (insert string)
+ (when strip-operator-p ; `(OP arg1 arg2 ...)' ==> `(arg1 arg2 ...)'
+ (goto-char (point-min))
+ (when (string= (thing-at-point 'char) "(")
+ (ignore-errors (forward-char 1)
+ (forward-sexp)
+ (slime-forward-blanks))
+ (delete-region (point-min) (point))
+ (insert "(")))
+ (goto-char (1- (point-max))) ; `(OP arg1 ... argN|)'
+ (assert (eql (char-after) ?\)))
+ (multiple-value-bind (forms indices points)
+ (slime-enclosing-form-specs 1)
+ (if (null forms)
+ string
+ (let ((n (first (last indices))))
+ (goto-char (1+ (point-min))) ; `(|OP arg1 ... argN)'
+ (mapcar #'(lambda (s)
+ (assert (not (equal s string))) ; trap against
+ (slime-make-form-spec-from-string s)) ; endless recursion.
+ (slime-ensure-list
+ (slime-parse-sexp-at-point (1+ n) t))))))))))
+
+
+(defun slime-enclosing-form-specs (&optional max-levels)
+ "Return the list of ``raw form specs'' of all the forms
+containing point from right to left.
+
+As a secondary value, return a list of indices: Each index tells
+for each corresponding form spec in what argument position the
+user's point is.
+
+As tertiary value, return the positions of the operators that are
+contained in the returned form specs.
+
+When MAX-LEVELS is non-nil, go up at most this many levels of
+parens.
+
+\(See SWANK::PARSE-FORM-SPEC for more information about what
+exactly constitutes a ``raw form specs'')
+
+Examples:
+
+ A return value like the following
+
+ (values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3))
+
+ can be interpreted as follows:
+
+ The user point is located in the 3rd argument position of a
+ form with the operator name \"quux\" (which starts at P1.)
+
+ This form is located in the 2nd argument position of a form
+ with the operator name \"bar\" (which starts at P2.)
+
+ This form again is in the 1st argument position of a form
+ with the operator name \"foo\" (which itself begins at P3.)
+
+ For instance, the corresponding buffer content could have looked
+ like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point.
+"
+ (let ((level 1)
+ (parse-sexp-lookup-properties nil)
+ (initial-point (point))
+ (result '()) (arg-indices '()) (points '()))
+ ;; The expensive lookup of syntax-class text properties is only
+ ;; used for interactive balancing of #<...> in presentations; we
+ ;; do not need them in navigating through the nested lists.
+ ;; This speeds up this function significantly.
+ (ignore-errors
+ (save-excursion
+ ;; Make sure we get the whole thing at point.
+ (if (not (slime-inside-string-p))
+ (slime-end-of-symbol)
+ (slime-beginning-of-string)
+ (forward-sexp))
+ (save-restriction
+ ;; Don't parse more than 20000 characters before point, so we don't spend
+ ;; too much time.
+ (narrow-to-region (max (point-min) (- (point) 20000)) (point-max))
+ (narrow-to-region (save-excursion (beginning-of-defun) (point))
+ (min (1+ (point)) (point-max)))
+ (while (or (not max-levels)
+ (<= level max-levels))
+ (let ((arg-index 0))
+ ;; Move to the beginning of the current sexp if not already there.
+ (if (or (and (char-after)
+ (member (char-syntax (char-after)) '(?\( ?')))
+ (member (char-syntax (char-before)) '(?\ ?>)))
+ (incf arg-index))
+ (ignore-errors (backward-sexp 1))
+ (while (and (< arg-index 64)
+ (ignore-errors (backward-sexp 1)
+ (> (point) (point-min))))
+ (incf arg-index))
+ (backward-up-list 1)
+ (when (member (char-syntax (char-after)) '(?\( ?'))
+ (incf level)
+ (forward-char 1)
+ (let ((name (slime-symbol-name-at-point)))
+ (cond
+ (name
+ (save-restriction
+ (widen) ; to allow looking-ahead/back in extended parsing.
+ (multiple-value-bind (new-result new-indices new-points)
+ (slime-parse-extended-operator-name initial-point
+ (cons `(,name) result) ; minimal form spec
+ (cons arg-index arg-indices)
+ (cons (point) points))
+ (setq result new-result)
+ (setq arg-indices new-indices)
+ (setq points new-points))))
+ (t
+ (push nil result)
+ (push arg-index arg-indices)
+ (push (point) points))))
+ (backward-up-list 1)))))))
+ (values
+ (nreverse result)
+ (nreverse arg-indices)
+ (nreverse points))))
+
+
+(defun slime-ensure-list (thing)
+ (if (listp thing) thing (list thing)))
+
+(defun slime-inside-string-p ()
+ (let* ((toplevel-begin (save-excursion (beginning-of-defun) (point)))
+ (parse-result (parse-partial-sexp toplevel-begin (point)))
+ (inside-string-p (nth 3 parse-result))
+ (string-start-pos (nth 8 parse-result)))
+ (and inside-string-p string-start-pos)))
+
+(defun slime-beginning-of-string ()
+ (let ((string-start-pos (slime-inside-string-p)))
+ (if string-start-pos
+ (goto-char string-start-pos)
+ (error "We're not within a string"))))
+
+(provide 'slime-parse)
+
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-presentation-streams.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-presentation-streams.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,29 @@
+;;; swank-presentation-streams.el --- Streams that allow attaching object identities
+;;; to portions of output
+;;;
+;;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net>
+;;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;;; Helmut Eller <heller(a)common-lisp.net>
+;;;
+;;; License: GNU GPL (same license as Emacs)
+;;;
+;;; Installation
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentation-streams)))
+;;
+
+
+;;; Initialization
+
+(require 'slime-presentations)
+
+(add-hook 'slime-connected-hook 'slime-install-presentation-streams)
+
+(defun slime-install-presentation-streams ()
+ (slime-eval-async '(swank:swank-require :swank-presentation-streams)))
+
+(provide 'slime-presentation-streams)
+
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-presentations.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-presentations.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,807 @@
+;;; swank-presentations.el --- imitat LispM' presentations
+;;;
+;;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net>
+;;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;;;
+;;; License: GNU GPL (same license as Emacs)
+;;;
+;;; Installation
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentations)))
+;;
+
+(defface slime-repl-output-mouseover-face
+ (if (featurep 'xemacs)
+ '((t (:bold t)))
+ (if (slime-face-inheritance-possible-p)
+ '((t
+ (:box
+ (:line-width 1 :color "black" :style released-button)
+ :inherit
+ slime-repl-inputed-output-face)))
+ '((t (:box (:line-width 1 :color "black"))))))
+ "Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
+ :group 'slime-repl)
+
+(defface slime-repl-inputed-output-face
+ '((((class color) (background light)) (:foreground "Red"))
+ (((class color) (background dark)) (:foreground "Red"))
+ (t (:slant italic)))
+ "Face for the result of an evaluation in the SLIME REPL."
+ :group 'slime-repl)
+
+;; FIXME: This conditional is not right - just used because the code
+;; here does not work in XEmacs.
+(when (boundp 'text-property-default-nonsticky)
+ (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky
+ :test 'equal)
+ (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky
+ :test 'equal))
+
+(make-variable-buffer-local
+ (defvar slime-presentation-start-to-point (make-hash-table)))
+
+(defun slime-mark-presentation-start (id &optional target)
+ "Mark the beginning of a presentation with the given ID.
+TARGET can be nil (regular process output) or :repl-result."
+ (setf (gethash id slime-presentation-start-to-point)
+ ;; We use markers because text can also be inserted before this presentation.
+ ;; (Output arrives while we are writing presentations within REPL results.)
+ (copy-marker (slime-output-target-marker target) nil)))
+
+(defun slime-mark-presentation-start-handler (process string)
+ (if (and string (string-match "<\\([-0-9]+\\)" string))
+ (let* ((match (substring string (match-beginning 1) (match-end 1)))
+ (id (car (read-from-string match))))
+ (slime-mark-presentation-start id))))
+
+(defun slime-mark-presentation-end (id &optional target)
+ "Mark the end of a presentation with the given ID.
+TARGET can be nil (regular process output) or :repl-result."
+ (let ((start (gethash id slime-presentation-start-to-point)))
+ (remhash id slime-presentation-start-to-point)
+ (when start
+ (let* ((marker (slime-output-target-marker target))
+ (buffer (and marker (marker-buffer marker))))
+ (with-current-buffer buffer
+ (let ((end (marker-position marker)))
+ (slime-add-presentation-properties start end
+ id nil)))))))
+
+(defun slime-mark-presentation-end-handler (process string)
+ (if (and string (string-match ">\\([-0-9]+\\)" string))
+ (let* ((match (substring string (match-beginning 1) (match-end 1)))
+ (id (car (read-from-string match))))
+ (slime-mark-presentation-end id))))
+
+(defstruct slime-presentation text id)
+
+(defvar slime-presentation-syntax-table
+ (let ((table (copy-syntax-table lisp-mode-syntax-table)))
+ ;; We give < and > parenthesis syntax, so that #< ... > is treated
+ ;; as a balanced expression. This allows to use C-M-k, C-M-SPC,
+ ;; etc. to deal with a whole presentation. (For Lisp mode, this
+ ;; is not desirable, since we do not wish to get a mismatched
+ ;; paren highlighted everytime we type < or >.)
+ (modify-syntax-entry ?< "(>" table)
+ (modify-syntax-entry ?> ")<" table)
+ table)
+ "Syntax table for presentations.")
+
+(defun slime-add-presentation-properties (start end id result-p)
+ "Make the text between START and END a presentation with ID.
+RESULT-P decides whether a face for a return value or output text is used."
+ (let* ((text (buffer-substring-no-properties start end))
+ (presentation (make-slime-presentation :text text :id id)))
+ (let ((inhibit-modification-hooks t))
+ (add-text-properties start end
+ `(modification-hooks (slime-after-change-function)
+ insert-in-front-hooks (slime-after-change-function)
+ insert-behind-hooks (slime-after-change-function)
+ syntax-table ,slime-presentation-syntax-table
+ rear-nonsticky t))
+ ;; Use the presentation as the key of a text property
+ (case (- end start)
+ (0)
+ (1
+ (add-text-properties start end
+ `(slime-repl-presentation ,presentation
+ ,presentation :start-and-end)))
+ (t
+ (add-text-properties start (1+ start)
+ `(slime-repl-presentation ,presentation
+ ,presentation :start))
+ (when (> (- end start) 2)
+ (add-text-properties (1+ start) (1- end)
+ `(,presentation :interior)))
+ (add-text-properties (1- end) end
+ `(slime-repl-presentation ,presentation
+ ,presentation :end))))
+ ;; Also put an overlay for the face and the mouse-face. This enables
+ ;; highlighting of nested presentations. However, overlays get lost
+ ;; when we copy a presentation; their removal is also not undoable.
+ ;; In these cases the mouse-face text properties need to take over ---
+ ;; but they do not give nested highlighting.
+ (slime-ensure-presentation-overlay start end presentation))))
+
+(defun slime-ensure-presentation-overlay (start end presentation)
+ (unless (find presentation (overlays-at start)
+ :key (lambda (overlay)
+ (overlay-get overlay 'slime-repl-presentation)))
+ (let ((overlay (make-overlay start end (current-buffer) t nil)))
+ (overlay-put overlay 'slime-repl-presentation presentation)
+ (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face)
+ (overlay-put overlay 'help-echo
+ (if (eq major-mode 'slime-repl-mode)
+ "mouse-2: copy to input; mouse-3: menu"
+ "mouse-2: inspect; mouse-3: menu"))
+ (overlay-put overlay 'face 'slime-repl-inputed-output-face)
+ (overlay-put overlay 'keymap slime-presentation-map))))
+
+(defun slime-remove-presentation-properties (from to presentation)
+ (let ((inhibit-read-only t))
+ (remove-text-properties from to
+ `(,presentation t syntax-table t rear-nonsticky t))
+ (when (eq (get-text-property from 'slime-repl-presentation) presentation)
+ (remove-text-properties from (1+ from) `(slime-repl-presentation t)))
+ (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation)
+ (remove-text-properties (1- to) to `(slime-repl-presentation t)))
+ (dolist (overlay (overlays-at from))
+ (when (eq (overlay-get overlay 'slime-repl-presentation) presentation)
+ (delete-overlay overlay)))))
+
+(defun slime-insert-presentation (string output-id &optional rectangle)
+ "Insert STRING in current buffer and mark it as a presentation
+corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line
+strings to line up below the current point."
+ (flet ((insert-it ()
+ (if rectangle
+ (slime-insert-indented string)
+ (insert string))))
+ (let ((start (point)))
+ (insert-it)
+ (slime-add-presentation-properties start (point) output-id t))))
+
+(defun slime-presentation-whole-p (presentation start end &optional object)
+ (let ((object (or object (current-buffer))))
+ (string= (etypecase object
+ (buffer (with-current-buffer object
+ (buffer-substring-no-properties start end)))
+ (string (substring-no-properties object start end)))
+ (slime-presentation-text presentation))))
+
+(defun slime-presentations-around-point (point &optional object)
+ (let ((object (or object (current-buffer))))
+ (loop for (key value . rest) on (text-properties-at point object) by 'cddr
+ when (slime-presentation-p key)
+ collect key)))
+
+(defun slime-presentation-start-p (tag)
+ (memq tag '(:start :start-and-end)))
+
+(defun slime-presentation-stop-p (tag)
+ (memq tag '(:end :start-and-end)))
+
+(defun* slime-presentation-start (point presentation
+ &optional (object (current-buffer)))
+ "Find start of `presentation' at `point' in `object'.
+Return buffer index and whether a start-tag was found."
+ (let* ((this-presentation (get-text-property point presentation object)))
+ (while (not (slime-presentation-start-p this-presentation))
+ (let ((change-point (previous-single-property-change
+ point presentation object)))
+ (unless change-point
+ (return-from slime-presentation-start
+ (values (etypecase object
+ (buffer (with-current-buffer object 1))
+ (string 0))
+ nil)))
+ (setq this-presentation (get-text-property change-point
+ presentation object))
+ (unless this-presentation
+ (return-from slime-presentation-start
+ (values point nil)))
+ (setq point change-point)))
+ (values point t)))
+
+(defun* slime-presentation-end (point presentation
+ &optional (object (current-buffer)))
+ "Find end of presentation at `point' in `object'. Return buffer
+index (after last character of the presentation) and whether an
+end-tag was found."
+ (let* ((this-presentation (get-text-property point presentation object)))
+ (while (not (slime-presentation-stop-p this-presentation))
+ (let ((change-point (next-single-property-change
+ point presentation object)))
+ (unless change-point
+ (return-from slime-presentation-end
+ (values (etypecase object
+ (buffer (with-current-buffer object (point-max)))
+ (string (length object)))
+ nil)))
+ (setq point change-point)
+ (setq this-presentation (get-text-property point
+ presentation object))))
+ (if this-presentation
+ (let ((after-end (next-single-property-change point
+ presentation object)))
+ (if (not after-end)
+ (values (etypecase object
+ (buffer (with-current-buffer object (point-max)))
+ (string (length object)))
+ t)
+ (values after-end t)))
+ (values point nil))))
+
+(defun* slime-presentation-bounds (point presentation
+ &optional (object (current-buffer)))
+ "Return start index and end index of `presentation' around `point'
+in `object', and whether the presentation is complete."
+ (multiple-value-bind (start good-start)
+ (slime-presentation-start point presentation object)
+ (multiple-value-bind (end good-end)
+ (slime-presentation-end point presentation object)
+ (values start end
+ (and good-start good-end
+ (slime-presentation-whole-p presentation
+ start end object))))))
+
+(defun slime-presentation-around-point (point &optional object)
+ "Return presentation, start index, end index, and whether the
+presentation is complete."
+ (let ((object (or object (current-buffer)))
+ (innermost-presentation nil)
+ (innermost-start 0)
+ (innermost-end most-positive-fixnum))
+ (dolist (presentation (slime-presentations-around-point point object))
+ (multiple-value-bind (start end whole-p)
+ (slime-presentation-bounds point presentation object)
+ (when whole-p
+ (when (< (- end start) (- innermost-end innermost-start))
+ (setq innermost-start start
+ innermost-end end
+ innermost-presentation presentation)))))
+ (values innermost-presentation
+ innermost-start innermost-end)))
+
+(defun slime-presentation-around-or-before-point (point &optional object)
+ (let ((object (or object (current-buffer))))
+ (multiple-value-bind (presentation start end whole-p)
+ (slime-presentation-around-point point object)
+ (if presentation
+ (values presentation start end whole-p)
+ (slime-presentation-around-point (1- point) object)))))
+
+(defun slime-presentation-around-or-before-point-or-error (point)
+ (multiple-value-bind (presentation start end whole-p)
+ (slime-presentation-around-or-before-point point)
+ (unless presentation
+ (error "No presentation at point"))
+ (values presentation start end whole-p)))
+
+(defun* slime-for-each-presentation-in-region (from to function &optional (object (current-buffer)))
+ "Call `function' with arguments `presentation', `start', `end',
+`whole-p' for every presentation in the region `from'--`to' in the
+string or buffer `object'."
+ (flet ((handle-presentation (presentation point)
+ (multiple-value-bind (start end whole-p)
+ (slime-presentation-bounds point presentation object)
+ (funcall function presentation start end whole-p))))
+ ;; Handle presentations active at `from'.
+ (dolist (presentation (slime-presentations-around-point from object))
+ (handle-presentation presentation from))
+ ;; Use the `slime-repl-presentation' property to search for new presentations.
+ (let ((point from))
+ (while (< point to)
+ (setq point (next-single-property-change point 'slime-repl-presentation object to))
+ (let* ((presentation (get-text-property point 'slime-repl-presentation object))
+ (status (get-text-property point presentation object)))
+ (when (slime-presentation-start-p status)
+ (handle-presentation presentation point)))))))
+
+;; XEmacs compatibility hack, from message by Stephen J. Turnbull on
+;; xemacs-beta(a)xemacs.org of 18 Mar 2002
+(unless (boundp 'undo-in-progress)
+ (defvar undo-in-progress nil
+ "Placeholder defvar for XEmacs compatibility from SLIME.")
+ (defadvice undo-more (around slime activate)
+ (let ((undo-in-progress t)) ad-do-it)))
+
+(defun slime-after-change-function (start end &rest ignore)
+ "Check all presentations within and adjacent to the change.
+When a presentation has been altered, change it to plain text."
+ (let ((inhibit-modification-hooks t))
+ (let ((real-start (max 1 (1- start)))
+ (real-end (min (1+ (buffer-size)) (1+ end)))
+ (any-change nil))
+ ;; positions around the change
+ (slime-for-each-presentation-in-region
+ real-start real-end
+ (lambda (presentation from to whole-p)
+ (cond
+ (whole-p
+ (slime-ensure-presentation-overlay from to presentation))
+ ((not undo-in-progress)
+ (slime-remove-presentation-properties from to
+ presentation)
+ (setq any-change t)))))
+ (when any-change
+ (undo-boundary)))))
+
+(defun slime-presentation-around-click (event)
+ "Return the presentation around the position of the mouse-click EVENT.
+If there is no presentation, signal an error.
+Also return the start position, end position, and buffer of the presentation."
+ (when (and (featurep 'xemacs) (not (button-press-event-p event)))
+ (error "Command must be bound to a button-press-event"))
+ (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event))))
+ (window (if (featurep 'xemacs) (event-window event) (caadr event))))
+ (with-current-buffer (window-buffer window)
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-point point)
+ (unless presentation
+ (error "No presentation at click"))
+ (values presentation start end (current-buffer))))))
+
+(defun slime-copy-or-inspect-presentation-at-mouse (event)
+ (interactive "e") ; no "@" -- we don't want to select the clicked-at window
+ (multiple-value-bind (presentation start end buffer)
+ (slime-presentation-around-click event)
+ (if (with-current-buffer buffer
+ (eq major-mode 'slime-repl-mode))
+ (slime-copy-presentation-at-mouse-to-repl event)
+ (slime-inspect-presentation-at-mouse event))))
+
+(defun slime-inspect-presentation (presentation start end buffer)
+ (let ((reset-p
+ (with-current-buffer buffer
+ (not (eq major-mode 'slime-inspector-mode)))))
+ (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p)
+ 'slime-open-inspector)))
+
+(defun slime-inspect-presentation-at-mouse (event)
+ (interactive "e")
+ (multiple-value-bind (presentation start end buffer)
+ (slime-presentation-around-click event)
+ (slime-inspect-presentation presentation start end buffer)))
+
+(defun slime-inspect-presentation-at-point (point)
+ (interactive "d")
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-or-before-point-or-error point)
+ (slime-inspect-presentation presentation start end (current-buffer))))
+
+(defun slime-copy-presentation-to-repl (presentation start end buffer)
+ (let ((presentation-text
+ (with-current-buffer buffer
+ (buffer-substring start end))))
+ (unless (eql major-mode 'slime-repl-mode)
+ (slime-switch-to-output-buffer))
+ (flet ((do-insertion ()
+ (when (not (string-match "\\s-"
+ (buffer-substring (1- (point)) (point))))
+ (insert " "))
+ (insert presentation-text)
+ (when (and (not (eolp)) (not (looking-at "\\s-")))
+ (insert " "))))
+ (if (>= (point) slime-repl-prompt-start-mark)
+ (do-insertion)
+ (save-excursion
+ (goto-char (point-max))
+ (do-insertion))))))
+
+(defun slime-copy-presentation-at-mouse-to-repl (event)
+ (interactive "e")
+ (multiple-value-bind (presentation start end buffer)
+ (slime-presentation-around-click event)
+ (slime-copy-presentation-to-repl presentation start end buffer)))
+
+(defun slime-copy-presentation-at-point-to-repl (point)
+ (interactive "d")
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-or-before-point-or-error point)
+ (slime-copy-presentation-to-repl presentation start end (current-buffer))))
+
+(defun slime-copy-presentation-at-mouse-to-point (event)
+ (interactive "e")
+ (multiple-value-bind (presentation start end buffer)
+ (slime-presentation-around-click event)
+ (let ((presentation-text
+ (with-current-buffer buffer
+ (buffer-substring start end))))
+ (when (not (string-match "\\s-"
+ (buffer-substring (1- (point)) (point))))
+ (insert " "))
+ (insert presentation-text)
+ (slime-after-change-function (point) (point))
+ (when (and (not (eolp)) (not (looking-at "\\s-")))
+ (insert " ")))))
+
+(defun slime-copy-presentation-to-kill-ring (presentation start end buffer)
+ (let ((presentation-text
+ (with-current-buffer buffer
+ (buffer-substring start end))))
+ (kill-new presentation-text)
+ (message "Saved presentation \"%s\" to kill ring" presentation-text)))
+
+(defun slime-copy-presentation-at-mouse-to-kill-ring (event)
+ (interactive "e")
+ (multiple-value-bind (presentation start end buffer)
+ (slime-presentation-around-click event)
+ (slime-copy-presentation-to-kill-ring presentation start end buffer)))
+
+(defun slime-copy-presentation-at-point-to-kill-ring (point)
+ (interactive "d")
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-or-before-point-or-error point)
+ (slime-copy-presentation-to-kill-ring presentation start end (current-buffer))))
+
+(defun slime-describe-presentation (presentation)
+ (slime-eval-describe
+ `(swank::describe-to-string
+ (swank::lookup-presented-object ',(slime-presentation-id presentation)))))
+
+(defun slime-describe-presentation-at-mouse (event)
+ (interactive "@e")
+ (multiple-value-bind (presentation) (slime-presentation-around-click event)
+ (slime-describe-presentation presentation)))
+
+(defun slime-describe-presentation-at-point (point)
+ (interactive "d")
+ (multiple-value-bind (presentation)
+ (slime-presentation-around-or-before-point-or-error point)
+ (slime-describe-presentation presentation)))
+
+(defun slime-pretty-print-presentation (presentation)
+ (slime-eval-describe
+ `(swank::swank-pprint
+ (cl:list
+ (swank::lookup-presented-object ',(slime-presentation-id presentation))))))
+
+(defun slime-pretty-print-presentation-at-mouse (event)
+ (interactive "@e")
+ (multiple-value-bind (presentation) (slime-presentation-around-click event)
+ (slime-pretty-print-presentation presentation)))
+
+(defun slime-pretty-print-presentation-at-point (point)
+ (interactive "d")
+ (multiple-value-bind (presentation)
+ (slime-presentation-around-or-before-point-or-error point)
+ (slime-pretty-print-presentation presentation)))
+
+(defun slime-mark-presentation (point)
+ (interactive "d")
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-or-before-point-or-error point)
+ (goto-char start)
+ (push-mark end nil t)))
+
+(defun slime-previous-presentation ()
+ "Move point to the beginning of the first presentation before point."
+ (interactive)
+ ;; First skip outside the current surrounding presentation (if any)
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-point (point))
+ (when presentation
+ (goto-char start)))
+ (let ((p (previous-single-property-change (point) 'slime-repl-presentation)))
+ (unless p
+ (error "No previous presentation"))
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-or-before-point-or-error p)
+ (goto-char start))))
+
+(defun slime-next-presentation ()
+ "Move point to the beginning of the next presentation after point."
+ (interactive)
+ ;; First skip outside the current surrounding presentation (if any)
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-point (point))
+ (when presentation
+ (goto-char end)))
+ (let ((p (next-single-property-change (point) 'slime-repl-presentation)))
+ (unless p
+ (error "No next presentation"))
+ (multiple-value-bind (presentation start end)
+ (slime-presentation-around-or-before-point-or-error p)
+ (goto-char start))))
+
+(defvar slime-presentation-map (make-sparse-keymap))
+
+(define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse)
+(define-key slime-presentation-map [mouse-3] 'slime-presentation-menu)
+
+(when (featurep 'xemacs)
+ (define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse)
+ (define-key slime-presentation-map [button3] 'slime-presentation-menu))
+
+;; protocol for handling up a menu.
+;; 1. Send lisp message asking for menu choices for this object.
+;; Get back list of strings.
+;; 2. Let used choose
+;; 3. Call back to execute menu choice, passing nth and string of choice
+
+(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda)
+ "Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'."
+ (let* ((what (slime-presentation-id presentation))
+ (choices (with-current-buffer buffer
+ (slime-eval
+ `(swank::menu-choices-for-presentation-id ',what)))))
+ (flet ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name
+ (let ((sym (gensym)))
+ (setf (gethash sym choice-to-lambda) f)
+ sym)))
+ (etypecase choices
+ (list
+ `(,(format "Presentation %s" what)
+ (""
+ ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse))
+ ("Describe" . ,(savel 'slime-describe-presentation-at-mouse))
+ ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse))
+ ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl))
+ ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring))
+ ,@(unless buffer-read-only
+ `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point))))
+ ,@(let ((nchoice 0))
+ (mapcar
+ (lambda (choice)
+ (incf nchoice)
+ (cons choice
+ (savel `(lambda ()
+ (interactive)
+ (slime-eval
+ '(swank::execute-menu-choice-for-presentation-id
+ ',what ,nchoice ,(nth (1- nchoice) choices)))))))
+ choices)))))
+ (symbol ; not-present
+ (with-current-buffer buffer
+ (slime-remove-presentation-properties from to presentation))
+ (sit-for 0) ; allow redisplay
+ `("Object no longer recorded"
+ ("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))))
+
+(defun slime-presentation-menu (event)
+ (interactive "e")
+ (let* ((point (if (featurep 'xemacs) (event-point event)
+ (posn-point (event-end event))))
+ (window (if (featurep 'xemacs) (event-window event) (caadr event)))
+ (buffer (window-buffer window))
+ (choice-to-lambda (make-hash-table)))
+ (multiple-value-bind (presentation from to)
+ (with-current-buffer buffer
+ (slime-presentation-around-point point))
+ (unless presentation
+ (error "No presentation at event position"))
+ (let ((menu (slime-menu-choices-for-presentation
+ presentation buffer from to choice-to-lambda)))
+ (let ((choice (x-popup-menu event menu)))
+ (when choice
+ (call-interactively (gethash choice choice-to-lambda))))))))
+
+(defun slime-presentation-expression (presentation)
+ "Return a string that contains a CL s-expression accessing
+the presented object."
+ (let ((id (slime-presentation-id presentation)))
+ (etypecase id
+ (number
+ ;; Make sure it works even if *read-base* is not 10.
+ (format "(swank:get-repl-result #10r%d)" id))
+ (list
+ ;; for frame variables and inspector parts
+ (format "(swank:get-repl-result '%s)" id)))))
+
+(defun slime-buffer-substring-with-reified-output (start end)
+ (let ((str-props (buffer-substring start end))
+ (str-no-props (buffer-substring-no-properties start end)))
+ (slime-reify-old-output str-props str-no-props)))
+
+(defun slime-reify-old-output (str-props str-no-props)
+ (let ((pos (slime-property-position 'slime-repl-presentation str-props)))
+ (if (null pos)
+ str-no-props
+ (multiple-value-bind (presentation start-pos end-pos whole-p)
+ (slime-presentation-around-point pos str-props)
+ (if (not presentation)
+ str-no-props
+ (concat (substring str-no-props 0 pos)
+ ;; Eval in the reader so that we play nice with quote.
+ ;; -luke (19/May/2005)
+ "#." (slime-presentation-expression presentation)
+ (slime-reify-old-output (substring str-props end-pos)
+ (substring str-no-props end-pos))))))))
+
+
+
+(defun slime-repl-grab-old-output (replace)
+ "Resend the old REPL output at point.
+If replace it non-nil the current input is replaced with the old
+output; otherwise the new input is appended."
+ (multiple-value-bind (presentation beg end)
+ (slime-presentation-around-or-before-point (point))
+ (let ((old-output (buffer-substring beg end))) ;;keep properties
+ ;; Append the old input or replace the current input
+ (cond (replace (goto-char slime-repl-input-start-mark))
+ (t (goto-char slime-repl-input-end-mark)
+ (unless (eq (char-before) ?\ )
+ (insert " "))))
+ (delete-region (point) slime-repl-input-end-mark)
+ (let ((inhibit-read-only t))
+ (insert old-output)))))
+
+;;; Presentation-related key bindings, non-context menu
+
+(defvar slime-presentation-command-map (make-sparse-keymap)
+ "Keymap for presentation-related commands. Bound to a prefix key.")
+
+(defvar slime-presentation-bindings
+ '((?i slime-inspect-presentation-at-point)
+ (?d slime-describe-presentation-at-point)
+ (?w slime-copy-presentation-at-point-to-kill-ring)
+ (?r slime-copy-presentation-at-point-to-repl)
+ (?p slime-previous-presentation)
+ (?n slime-next-presentation)
+ (? slime-mark-presentation)))
+
+(defun slime-presentation-init-keymaps ()
+ (setq slime-presentation-command-map (make-sparse-keymap))
+ (loop for (key command) in slime-presentation-bindings
+ do (progn
+ ;; We bind both unmodified and with control.
+ (define-key slime-presentation-command-map (vector key) command)
+ (let ((modified (slime-control-modified-char key)))
+ (define-key slime-presentation-command-map (vector modified) command))))
+ (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
+ ;; C-c C-v is the prefix for the presentation-command map.
+ (slime-define-key "\C-v" slime-presentation-command-map :prefixed t :inferior t)
+ (define-key slime-repl-mode-map "\C-c\C-v" slime-presentation-command-map)
+ (define-key sldb-mode-map "\C-c\C-v" slime-presentation-command-map)
+ (define-key slime-inspector-mode-map "\C-c\C-v" slime-presentation-command-map))
+
+(defun slime-presentation-around-or-before-point-p ()
+ (multiple-value-bind (presentation beg end)
+ (slime-presentation-around-or-before-point (point))
+ presentation))
+
+(defvar slime-presentation-easy-menu
+ (let ((P '(slime-presentation-around-or-before-point-p)))
+ `("Presentations"
+ [ "Inspect" slime-inspect-presentation-at-point ,P ]
+ [ "Describe" slime-describe-presentation-at-point ,P ]
+ [ "Pretty-print" slime-pretty-print-presentation-at-point ,P ]
+ [ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ]
+ [ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ]
+ [ "Mark" slime-mark-presentation ,P ]
+ "--"
+ [ "Previous presentation" slime-previous-presentation ]
+ [ "Next presentation" slime-next-presentation ]
+ "--"
+ [ "Clear all presentations" slime-clear-presentations ])))
+
+(defun slime-presentation-add-easy-menu ()
+ (easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu)
+ (easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu)
+ (easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu)
+ (easy-menu-add slime-presentation-easy-menu 'slime-mode-map)
+ (easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map)
+ (easy-menu-add slime-presentation-easy-menu 'sldb-mode-map))
+
+;;; hook functions (hard to isolate stuff)
+
+(defun slime-dispatch-presentation-event (event)
+ (destructure-case event
+ ((:presentation-start id &optional target)
+ (slime-mark-presentation-start id target)
+ t)
+ ((:presentation-end id &optional target)
+ (slime-mark-presentation-end id target)
+ t)
+ (t nil)))
+
+(defun slime-presentation-write (string &optional target)
+ (case target
+ ((nil) ; Regular process output
+ (with-current-buffer (slime-output-buffer)
+ (slime-with-output-end-mark
+ (slime-propertize-region '(face slime-repl-output-face
+ rear-nonsticky (face))
+ (insert string))
+ (set-marker slime-output-end (point))
+ (when (and (= (point) slime-repl-prompt-start-mark)
+ (not (bolp)))
+ (insert "\n")
+ (set-marker slime-output-end (1- (point))))
+ (if (< slime-repl-input-start-mark (point))
+ (set-marker slime-repl-input-start-mark
+ (point))))))
+ (:repl-result
+ (with-current-buffer (slime-output-buffer)
+ (let ((marker (slime-output-target-marker target)))
+ (goto-char marker)
+ (let ((result-start (point)))
+ (slime-propertize-region `(face slime-repl-result-face
+ rear-nonsticky (face))
+ (insert string))
+ ;; Move the input-start marker after the REPL result.
+ (set-marker marker (point))))))
+ (t
+ (let* ((marker (slime-output-target-marker target))
+ (buffer (and marker (marker-buffer marker))))
+ (when buffer
+ (with-current-buffer buffer
+ (save-excursion
+ ;; Insert STRING at MARKER, then move MARKER behind
+ ;; the insertion.
+ (goto-char marker)
+ (insert-before-markers string)
+ (set-marker marker (point)))))))))
+
+(defun slime-presentation-current-input (&optional until-point-p)
+ "Return the current input as string.
+The input is the region from after the last prompt to the end of
+buffer. Presentations of old results are expanded into code."
+ (slime-buffer-substring-with-reified-output slime-repl-input-start-mark
+ (if (and until-point-p
+ (<= (point) slime-repl-input-end-mark))
+ (point)
+ slime-repl-input-end-mark)))
+(defun slime-presentation-on-return-pressed ()
+ (cond ((and (car (slime-presentation-around-or-before-point (point)))
+ (< (point) slime-repl-input-start-mark))
+ (slime-repl-grab-old-output end-of-input)
+ (slime-repl-recenter-if-needed)
+ t)
+ (t nil)))
+
+(defun slime-presentation-on-stream-open (stream)
+ (require 'bridge)
+ (defun bridge-insert (process output)
+ (slime-output-filter process (or output "")))
+ (install-bridge)
+ (setq bridge-destination-insert nil)
+ (setq bridge-source-insert nil)
+ (setq bridge-handlers
+ (list* '("<" . slime-mark-presentation-start-handler)
+ '(">" . slime-mark-presentation-end-handler)
+ bridge-handlers)))
+
+(defun slime-clear-presentations ()
+ "Forget all objects associated to SLIME presentations.
+This allows the garbage collector to remove these objects
+even on Common Lisp implementations without weak hash tables."
+ (interactive)
+ (slime-eval-async `(swank:clear-repl-results))
+ (unless (eql major-mode 'slime-repl-mode)
+ (slime-switch-to-output-buffer))
+ (slime-for-each-presentation-in-region 1 (1+ (buffer-size))
+ (lambda (presentation from to whole-p)
+ (slime-remove-presentation-properties from to
+ presentation))))
+
+;;; Initialization
+
+(defun slime-presentations-init ()
+ (add-hook 'slime-repl-mode-hook
+ (lambda ()
+ ;; Respect the syntax text properties of presentation.
+ (set (make-local-variable 'parse-sexp-lookup-properties) t)
+ (add-local-hook 'after-change-functions
+ 'slime-after-change-function)))
+ (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event)
+ (setq slime-write-string-function 'slime-presentation-write)
+ (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed)
+ (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input)
+ (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
+ (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
+ (add-hook 'slime-connected-hook 'slime-install-presentations)
+ (slime-presentation-init-keymaps)
+ (slime-presentation-add-easy-menu))
+
+(defun slime-install-presentations ()
+ (slime-eval-async '(swank:swank-require :swank-presentations)))
+
+(slime-presentations-init)
+
+(provide 'slime-presentations)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-references.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-references.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,135 @@
+;;; slime-references.el --- Clickable references to documentation (SBCL only)
+;;
+;; Authors: Christophe Rhodes <csr21(a)cantab.net>
+;; Luke Gorrie <luke(a)bluetail.com>
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+;;;
+
+(defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/"
+ "*The base URL of the SBCL manual, for documentation lookup."
+ :type 'string
+ :group 'slime-mode)
+
+(defface sldb-reference-face
+ (list (list t '(:underline t)))
+ "Face for references."
+ :group 'slime-debugger)
+
+(defun slime-note.references (note)
+ (plist-get note :references))
+
+(defun slime-tree-print-with-references (tree)
+ ;; for SBCL-style references
+ (slime-tree-default-printer tree)
+ (when-let (note (plist-get (slime-tree.plist tree) 'note))
+ (when-let (references (slime-note.references note))
+ (terpri (current-buffer))
+ (princ "See also:" (current-buffer))
+ (terpri (current-buffer))
+ (slime-tree-insert-references references))))
+
+(defun slime-tree-insert-references (references)
+ "Insert documentation references from a condition.
+See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
+ (loop for refs on references
+ for ref = (car refs)
+ do
+ (destructuring-bind (where type what) ref
+ ;; FIXME: this is poorly factored, and shares some code and
+ ;; data with sldb that it shouldn't: notably
+ ;; sldb-reference-face. Probably the names of
+ ;; sldb-reference-foo should be altered to be not sldb
+ ;; specific.
+ (insert " " (sldb-format-reference-source where) ", ")
+ (slime-insert-propertized (sldb-reference-properties ref)
+ (sldb-format-reference-node what))
+ (insert (format " [%s]" type))
+ (when (cdr refs)
+ (terpri (current-buffer))))))
+
+
+;;;;; SLDB references (rather SBCL specific)
+
+(defun sldb-insert-references (references)
+ "Insert documentation references from a condition.
+See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
+ (dolist (ref references)
+ (destructuring-bind (where type what) ref
+ (insert "\n" (sldb-format-reference-source where) ", ")
+ (slime-insert-propertized (sldb-reference-properties ref)
+ (sldb-format-reference-node what))
+ (insert (format " [%s]" type)))))
+
+(defun sldb-reference-properties (reference)
+ "Return the properties for a reference.
+Only add clickability to properties we actually know how to lookup."
+ (destructuring-bind (where type what) reference
+ (if (or (and (eq where :sbcl) (eq type :node))
+ (and (eq where :ansi-cl)
+ (memq type '(:function :special-operator :macro
+ :section :glossary :issue))))
+ `(sldb-default-action
+ sldb-lookup-reference
+ ;; FIXME: this is a hack! slime-compiler-notes and sldb are a
+ ;; little too intimately entwined.
+ slime-compiler-notes-default-action sldb-lookup-reference
+ sldb-reference ,reference
+ face sldb-reference-face
+ mouse-face highlight))))
+
+(defun sldb-format-reference-source (where)
+ (case where
+ (:amop "The Art of the Metaobject Protocol")
+ (:ansi-cl "Common Lisp Hyperspec")
+ (:sbcl "SBCL Manual")
+ (t (format "%S" where))))
+
+(defun sldb-format-reference-node (what)
+ (if (listp what)
+ (mapconcat #'prin1-to-string what ".")
+ what))
+
+(defun sldb-lookup-reference ()
+ "Browse the documentation reference at point."
+ (destructuring-bind (where type what)
+ (get-text-property (point) 'sldb-reference)
+ (case where
+ (:ansi-cl
+ (case type
+ (:section
+ (browse-url (funcall common-lisp-hyperspec-section-fun what)))
+ (:glossary
+ (browse-url (funcall common-lisp-glossary-fun what)))
+ (:issue
+ (browse-url (funcall 'common-lisp-issuex what)))
+ (t
+ (hyperspec-lookup what))))
+ (t
+ (let ((url (format "%s%s.html" slime-sbcl-manual-root
+ (subst-char-in-string ?\ ?\- what))))
+ (browse-url url))))))
+
+(defun sldb-maybe-insert-references (extra)
+ (destructure-case extra
+ ((:references references)
+ (when references
+ (insert "\nSee also:")
+ (slime-with-rigid-indentation 2
+ (sldb-insert-references references)))
+ t)
+ (t nil)))
+
+
+;;; Initialization
+
+(defun slime-references-init ()
+ (setq slime-tree-printer 'slime-tree-print-with-references)
+ (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
+
+(defun slime-references-unload ()
+ (setq slime-tree-printer 'slime-tree-default-printer)
+ (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
+
+(provide 'slime-references)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-scheme.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-scheme.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,38 @@
+;;; slime-scheme.el --- Support Scheme programs running under Common Lisp
+;;
+;; Authors: Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;;
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-scheme)))
+;;
+
+(defun slime-scheme-mode-hook ()
+ (slime-mode 1))
+
+(defun slime-scheme-indentation-update (symbol indent)
+ ;; Does the symbol have an indentation value that we set?
+ (when (equal (get symbol 'scheme-indent-function)
+ (get symbol 'slime-scheme-indent))
+ (put symbol 'slime-scheme-indent indent)
+ (put symbol 'scheme-indent-function indent)))
+
+
+;;; Initialization
+
+(defun slime-scheme-init ()
+ (add-hook 'scheme-mode-hook 'slime-scheme-mode-hook)
+ (add-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update)
+ (add-to-list 'slime-lisp-modes 'scheme-mode))
+
+(defun slime-scheme-unload ()
+ (remove-hook 'scheme-mode-hook 'slime-scheme-mode-hook)
+ (remove-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update)
+ (setq slime-lisp-modes (remove 'scheme-mode slime-lisp-modes)))
+
+(provide 'slime-scheme)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-scratch.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-scratch.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,48 @@
+;;; slime-scratch.el --- imitate Emacs' *scratch* buffer
+;;
+;; Author: Helmut Eller <heller(a)common-lisp.net>
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this to your .emacs:
+;;
+;; (add-to-list 'load-path ".../slime/contrib")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-scratch)))
+;;
+
+
+;;; Code
+
+(defvar slime-scratch-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map lisp-mode-map)
+ map))
+
+(defun slime-scratch ()
+ (interactive)
+ (slime-switch-to-scratch-buffer))
+
+(defun slime-switch-to-scratch-buffer ()
+ (set-buffer (slime-scratch-buffer))
+ (unless (eq (current-buffer) (window-buffer))
+ (pop-to-buffer (current-buffer) t)))
+
+(defun slime-scratch-buffer ()
+ "Return the scratch buffer, create it if necessary."
+ (or (get-buffer "*slime-scratch*")
+ (with-current-buffer (get-buffer-create "*slime-scratch*")
+ (lisp-mode)
+ (use-local-map slime-scratch-mode-map)
+ (slime-mode t)
+ (current-buffer))))
+
+(slime-define-keys slime-scratch-mode-map
+ ("\C-j" 'slime-eval-print-last-expression))
+
+(defun slime-scratch-init ()
+ (def-slime-selector-method ?s
+ "*slime-scratch* buffer."
+ (slime-scratch-buffer)))
+
+(provide 'slime-scratch)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-tramp.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-tramp.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,55 @@
+;;; slime-tramp.el --- Filename translations for tramp
+;;
+;; Authors: Marco Baringer <mb(a)bese.it>
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this to your .emacs:
+;;
+;; (add-to-list 'load-path ".../slime/contrib")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-tramp)))
+;;
+
+(defun slime-make-tramp-file-name (username remote-host lisp-filename)
+ "Old (with multi-hops) tramp compatability function"
+ (require 'tramp)
+ (if (boundp 'tramp-multi-methods)
+ (tramp-make-tramp-file-name nil nil
+ username
+ remote-host
+ lisp-filename)
+ (tramp-make-tramp-file-name nil
+ username
+ remote-host
+ lisp-filename)))
+
+(defun* slime-create-filename-translator (&key machine-instance
+ remote-host
+ username)
+ "Creates a three element list suitable for push'ing onto
+slime-filename-translations which uses Tramp to load files on
+hostname using username. MACHINE-INSTANCE is a required
+parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME
+defaults to (user-login-name).
+
+MACHINE-INSTANCE is the value returned by slime-machine-instance,
+which is just the value returned by cl:machine-instance on the
+remote lisp. REMOTE-HOST is the fully qualified domain name (or
+just the IP) of the remote machine. USERNAME is the username we
+should login with.
+The functions created here expect your tramp-default-method or
+ tramp-default-method-alist to be setup correctly."
+ (lexical-let ((remote-host (or remote-host machine-instance))
+ (username (or username (user-login-name))))
+ (list (concat "^" machine-instance "$")
+ (lambda (emacs-filename)
+ (tramp-file-name-localname
+ (tramp-dissect-file-name emacs-filename)))
+ `(lambda (lisp-filename)
+ (slime-make-tramp-file-name
+ ,username
+ ,remote-host
+ lisp-filename)))))
+
+(provide 'slime-tramp)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-typeout-frame.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-typeout-frame.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,91 @@
+;;; slime-typeout-frame.el --- display some message in a dedicated frame
+;;
+;; Author: Luke Gorrie <luke(a)synap.se>
+;; License: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add something like this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-typeout-frame)))
+;;
+
+
+;;;; Typeout frame
+
+;; When a "typeout frame" exists it is used to display certain
+;; messages instead of the echo area or pop-up windows.
+
+(defvar slime-typeout-window nil
+ "The current typeout window.")
+
+(defvar slime-typeout-frame-properties
+ '((height . 10) (minibuffer . nil))
+ "The typeout frame properties (passed to `make-frame').")
+
+(defun slime-typeout-active-p ()
+ (and slime-typeout-window
+ (window-live-p slime-typeout-window)))
+
+(defun slime-typeout-message-aux (format-string &rest format-args)
+ (slime-ensure-typeout-frame)
+ (with-current-buffer (window-buffer slime-typeout-window)
+ (let ((msg (apply #'format format-string format-args)))
+ (unless (string= msg "")
+ (erase-buffer)
+ (insert msg)))))
+
+(defun slime-typeout-message (format-string &rest format-args)
+ (apply #'slime-typeout-message-aux format-string format-args)
+ ;; Disable the timer for autodoc temporarily, as it would overwrite
+ ;; the current typeout message otherwise.
+ (when (and (featurep 'slime-autodoc) slime-autodoc-mode)
+ (slime-autodoc-stop-timer)
+ (add-hook 'pre-command-hook #'slime-autodoc-start-timer)))
+
+(defun slime-make-typeout-frame ()
+ "Create a frame for displaying messages (e.g. arglists)."
+ (interactive)
+ (let ((frame (make-frame slime-typeout-frame-properties)))
+ (save-selected-window
+ (select-window (frame-selected-window frame))
+ (switch-to-buffer "*SLIME-Typeout*")
+ (setq slime-typeout-window (selected-window)))))
+
+(defun slime-ensure-typeout-frame ()
+ "Create the typeout frame unless it already exists."
+ (interactive)
+ (unless (slime-typeout-active-p)
+ (slime-make-typeout-frame)))
+
+(defun slime-typeout-autodoc-message (doc)
+ ;; No need for refreshing per `slime-autodoc-pre-command-refresh-echo-area'.
+ (setq slime-autodoc-last-message "")
+ (slime-typeout-message-aux "%s" doc))
+
+
+;;; Initialization
+
+(defvar slime-typeout-frame-unbind-stack ())
+
+(defun slime-typeout-frame-init ()
+ (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
+ (loop for (var value) in
+ '((slime-message-function slime-typeout-message)
+ (slime-background-message-function slime-typeout-message)
+ (slime-autodoc-message-function slime-typeout-autodoc-message))
+ do (slime-typeout-frame-init-var var value)))
+
+(defun slime-typeout-frame-init-var (var value)
+ (push (list var (if (boundp var) (symbol-value var) 'slime-unbound))
+ slime-typeout-frame-unbind-stack)
+ (set var value))
+
+(defun slime-typeout-frame-unload ()
+ (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
+ (loop for (var value) in slime-typeout-frame-unbind-stack
+ do (cond ((eq var 'slime-unbound) (makunbound var))
+ (t (set var value)))))
+
+(provide 'slime-typeout-frame)
Added: branches/bos/thirdparty/emacs/slime/contrib/slime-xref-browser.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/slime-xref-browser.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,104 @@
+;;; slime-xref-browser.el --- xref browsing with tree-widget
+;;
+;; Author: Rui Patroc�nio <rui.patrocinio(a)netvisao.pt>
+;; Licencse: GNU GPL (same license as Emacs)
+;;
+;;; Installation:
+;;
+;; Add this to your .emacs:
+;;
+;; (add-to-list 'load-path "<directory-of-this-file>")
+;; (add-hook 'slime-load-hook (lambda () (require 'slime-xref-browser)))
+;;
+
+
+;;;; classes browser
+
+(defun slime-expand-class-node (widget)
+ (or (widget-get widget :args)
+ (let ((name (widget-get widget :tag)))
+ (loop for kid in (slime-eval `(swank:mop :subclasses ,name))
+ collect `(tree-widget :tag ,kid
+ :dynargs slime-expand-class-node
+ :has-children t)))))
+
+(defun slime-browse-classes (name)
+ "Read the name of a class and show its subclasses."
+ (interactive (list (slime-read-symbol-name "Class Name: ")))
+ (slime-call-with-browser-setup
+ "*slime class browser*" (slime-current-package) "Class Browser"
+ (lambda ()
+ (widget-create 'tree-widget :tag name
+ :dynargs 'slime-expand-class-node
+ :has-echildren t))))
+
+(defvar slime-browser-map nil
+ "Keymap for tree widget browsers")
+
+(require 'tree-widget)
+(unless slime-browser-map
+ (setq slime-browser-map (make-sparse-keymap))
+ (set-keymap-parent slime-browser-map widget-keymap)
+ (define-key slime-browser-map "q" 'bury-buffer))
+
+(defun slime-call-with-browser-setup (buffer package title fn)
+ (switch-to-buffer buffer)
+ (kill-all-local-variables)
+ (setq slime-buffer-package package)
+ (let ((inhibit-read-only t)) (erase-buffer))
+ (widget-insert title "\n\n")
+ (save-excursion
+ (funcall fn))
+ (lisp-mode-variables t)
+ (slime-mode t)
+ (use-local-map slime-browser-map)
+ (widget-setup))
+
+
+;;;; Xref browser
+
+(defun slime-fetch-browsable-xrefs (type name)
+ "Return a list ((LABEL DSPEC)).
+LABEL is just a string for display purposes.
+DSPEC can be used to expand the node."
+ (let ((xrefs '()))
+ (loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do
+ (loop for (dspec . _location) in specs do
+ (let ((exp (ignore-errors (read (downcase dspec)))))
+ (cond ((and (consp exp) (eq 'flet (car exp)))
+ ;; we can't expand FLET references so they're useless
+ )
+ ((and (consp exp) (eq 'method (car exp)))
+ ;; this isn't quite right, but good enough for now
+ (push (list dspec (string (second exp))) xrefs))
+ (t
+ (push (list dspec dspec) xrefs))))))
+ xrefs))
+
+(defun slime-expand-xrefs (widget)
+ (or (widget-get widget :args)
+ (let* ((type (widget-get widget :xref-type))
+ (dspec (widget-get widget :xref-dspec))
+ (xrefs (slime-fetch-browsable-xrefs type dspec)))
+ (loop for (label dspec) in xrefs
+ collect `(tree-widget :tag ,label
+ :xref-type ,type
+ :xref-dspec ,dspec
+ :dynargs slime-expand-xrefs
+ :has-children t)))))
+
+(defun slime-browse-xrefs (name type)
+ "Show the xref graph of a function in a tree widget."
+ (interactive
+ (list (slime-read-from-minibuffer "Name: "
+ (slime-symbol-name-at-point))
+ (read (completing-read "Type: " (slime-bogus-completion-alist
+ '(":callers" ":callees" ":calls"))
+ nil t ":"))))
+ (slime-call-with-browser-setup
+ "*slime xref browser*" (slime-current-package) "Xref Browser"
+ (lambda ()
+ (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name
+ :dynargs 'slime-expand-xrefs :has-echildren t))))
+
+(provide 'slime-xref-browser)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-arglists.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-arglists.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,1212 @@
+;;; swank-arglists.lisp --- arglist related code ??
+;;
+;; Authors: Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; and others
+;;
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-c-p-c))
+
+(defun valid-operator-symbol-p (symbol)
+ "Is SYMBOL the name of a function, a macro, or a special-operator?"
+ (or (fboundp symbol)
+ (macro-function symbol)
+ (special-operator-p symbol)
+ (eq symbol 'declare)))
+
+(defun valid-operator-name-p (string)
+ "Is STRING the name of a function, macro, or special-operator?"
+ (let ((symbol (parse-symbol string)))
+ (valid-operator-symbol-p symbol)))
+
+(defslimefun arglist-for-echo-area (raw-specs &key arg-indices
+ print-right-margin print-lines)
+ "Return the arglist for the first valid ``form spec'' in
+RAW-SPECS. A ``form spec'' is a superset of functions, macros,
+special-ops, declarations and type specifiers.
+
+For more information about the format of ``raw form specs'' and
+``form specs'', please see PARSE-FORM-SPEC."
+ (handler-case
+ (with-buffer-syntax ()
+ (multiple-value-bind (form-spec position newly-interned-symbols)
+ (parse-first-valid-form-spec raw-specs #'read-conversatively-for-autodoc)
+ (unwind-protect
+ (when form-spec
+ (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
+ (unless (eql arglist :not-available)
+ (multiple-value-bind (type operator arguments)
+ (split-form-spec form-spec)
+ (declare (ignore arguments))
+ (multiple-value-bind (stringified-arglist)
+ (decoded-arglist-to-string
+ arglist
+ :operator operator
+ :print-right-margin print-right-margin
+ :print-lines print-lines
+ :highlight (let ((index (nth position arg-indices)))
+ ;; don't highlight the operator
+ (and index (not (zerop index)) index)))
+ ;; Post formatting:
+ (case type
+ (:type-specifier (format nil "[Typespec] ~A" stringified-arglist))
+ (:declaration
+ (locally (declare (special *arglist-pprint-bindings*))
+ (with-bindings *arglist-pprint-bindings*
+ (let ((op (%find-declaration-operator raw-specs position)))
+ (if op
+ (format nil "(~A ~A)" op stringified-arglist)
+ (format nil "[Declaration] ~A" stringified-arglist))))))
+ (t stringified-arglist)))))))
+ (mapc #'unintern-in-home-package newly-interned-symbols))))
+ (error (cond)
+ (format nil "ARGLIST (error): ~A" cond))
+ ))
+
+(defun %find-declaration-operator (raw-specs position)
+ (let ((op-rawspec (nth (1+ position) raw-specs)))
+ (first (parse-form-spec op-rawspec #'read-conversatively-for-autodoc))))
+
+;; This is a wrapper object around anything that came from Slime and
+;; could not reliably be read.
+(defstruct (arglist-dummy
+ (:conc-name #:arglist-dummy.)
+ (:print-object (lambda (struct stream)
+ (with-struct (arglist-dummy. string-representation) struct
+ (write-string string-representation stream)))))
+ string-representation)
+
+(defun read-conversatively-for-autodoc (string)
+ "Tries to find the symbol that's represented by STRING.
+
+If it can't, this either means that STRING does not represent a
+symbol, or that the symbol behind STRING would have to be freshly
+interned. Because this function is supposed to be called from the
+automatic arglist display stuff from Slime, interning freshly
+symbols is a big no-no.
+
+In such a case (that no symbol could be found), an object of type
+ARGLIST-DUMMY is returned instead, which works as a placeholder
+datum for subsequent logics to rely on."
+ (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string))
+ (quoted? (eql (aref string 0) #\')))
+ (multiple-value-bind (symbol found?)
+ (parse-symbol (if quoted? (subseq string 1) string))
+ (if found?
+ (if quoted? `(quote ,symbol) symbol)
+ (make-arglist-dummy :string-representation string)))))
+
+
+(defun parse-form-spec (raw-spec &optional reader)
+ "Takes a raw (i.e. unparsed) form spec from SLIME and returns a
+proper form spec for further processing within SWANK. Returns NIL
+if RAW-SPEC could not be parsed. Symbols that had to be interned
+in course of the conversion, are returned as secondary return value.
+
+A ``raw form spec'' can be either:
+
+ i) a list of strings representing a Common Lisp form
+
+ ii) a list of strings as of i), but which additionally
+ contains other raw form specs
+
+ iii) one of:
+
+ a) (:declaration declspec)
+
+ where DECLSPEC is a raw form spec.
+
+ b) (:type-specifier typespec)
+
+ where TYPESPEC is a raw form spec.
+
+
+A ``form spec'' is either
+
+ 1) a normal Common Lisp form
+
+ 2) a Common Lisp form with a list as its CAR specifying what namespace
+ the operator is supposed to be interpreted in:
+
+ a) ((:declaration decl-identifier) declarg1 declarg2 ...)
+
+ b) ((:type-specifier typespec-op) typespec-arg1 typespec-arg2 ...)
+
+
+Examples:
+
+ (\"defmethod\") => (defmethod)
+ (\"cl:defmethod\") => (cl:defmethod)
+ (\"defmethod\" \"print-object\") => (defmethod print-object)
+
+ (\"foo\" (\"bar\" (\"quux\")) \"baz\" => (foo (bar (quux)) baz)
+
+ (:declaration \"optimize\" \"(optimize)\") => ((:declaration optimize))
+ (:declaration \"type\" \"(type string)\") => ((:declaration type) string)
+ (:type-specifier \"float\" \"(float)\") => ((:type-specifier float))
+ (:type-specifier \"float\" \"(float 0 100)\") => ((:type-specifier float) 0 100)
+"
+ (flet ((parse-extended-spec (raw-extension extension-flag)
+ (when (and (stringp (first raw-extension)) ; (:DECLARATION (("a" "b" ("c")) "d"))
+ (nth-value 1 (parse-symbol (first raw-extension))))
+ (multiple-value-bind (extension introduced-symbols)
+ (read-form-spec raw-extension reader)
+ (unless (recursively-empty-p extension) ; (:DECLARATION (())) &c.
+ (destructuring-bind (identifier &rest args) extension
+ (values `((,extension-flag ,identifier) ,@args)
+ introduced-symbols)))))))
+ (when (consp raw-spec)
+ (destructure-case raw-spec
+ ((:declaration raw-declspec)
+ (parse-extended-spec raw-declspec :declaration))
+ ((:type-specifier raw-typespec)
+ (parse-extended-spec raw-typespec :type-specifier))
+ (t
+ (when (every #'(lambda (x) (or (stringp x) (consp x))) raw-spec)
+ (destructuring-bind (raw-operator &rest raw-args) raw-spec
+ (multiple-value-bind (operator found?) (parse-symbol raw-operator)
+ (when (and found? (valid-operator-symbol-p operator))
+ (multiple-value-bind (parsed-args introduced-symbols)
+ (read-form-spec raw-args reader)
+ (values `(,operator ,@parsed-args) introduced-symbols)))))))))))
+
+
+(defun split-form-spec (spec)
+ "Returns all three relevant information a ``form spec''
+contains: the operator type, the operator, and the operands."
+ (destructuring-bind (operator-designator &rest arguments) spec
+ (multiple-value-bind (type operator)
+ (if (listp operator-designator)
+ (values (first operator-designator) (second operator-designator))
+ (values :function operator-designator)) ; functions, macros, special ops
+ (values type operator arguments)))) ; are all fbound.
+
+(defun parse-first-valid-form-spec (raw-specs &optional reader)
+ "Returns the first parsed form spec in RAW-SPECS that can
+successfully be parsed. Additionally returns that spec's position
+as secondary, and all newly interned symbols as tertiary return
+value."
+ (loop for raw-spec in raw-specs
+ for pos upfrom 0
+ do (multiple-value-bind (spec symbols) (parse-form-spec raw-spec reader)
+ (when spec (return (values spec pos symbols))))))
+
+(defun read-form-spec (spec &optional reader)
+ "Turns the ``raw form spec'' SPEC into a proper Common Lisp
+form. As secondary return value, it returns all the symbols that
+had to be newly interned during the conversion.
+
+READER is a function that takes a string, and returns two values:
+the Common Lisp datum that the string represents, a flag whether
+the returned datum is a symbol and has been newly interned in
+some package.
+
+If READER is not explicitly given, the function
+READ-SOFTLY-FROM-STRING* is used instead."
+ (when spec
+ (with-buffer-syntax ()
+ (call-with-ignored-reader-errors
+ #'(lambda ()
+ (let ((result) (newly-interned-symbols) (ok))
+ (unwind-protect
+ (dolist (element spec (setq ok t))
+ (etypecase element
+ (string
+ (multiple-value-bind (sexp newly-interned?)
+ (funcall (or reader 'read-softly-from-string*) element)
+ (push sexp result)
+ (when newly-interned?
+ (push sexp newly-interned-symbols))))
+ (list
+ (multiple-value-bind (read-spec interned-symbols)
+ (read-form-spec element reader)
+ (push read-spec result)
+ (setf newly-interned-symbols
+ (append interned-symbols
+ newly-interned-symbols))))))
+ (unless ok
+ (mapc #'unintern-in-home-package newly-interned-symbols)))
+ (values (nreverse result)
+ (nreverse newly-interned-symbols))))))))
+
+(defun read-softly-from-string* (string)
+ "Like READ-SOFTLY-FROM-STRING, but only returns the sexp and
+the flag if a symbol had to be interned."
+ (multiple-value-bind (sexp pos interned?)
+ (read-softly-from-string string)
+ ;; To make sure that we haven't got any junk from Emacs.
+ (assert (= pos (length string)))
+ (values sexp interned?)))
+
+
+(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
+ provided-args ; list of the provided actual arguments
+ required-args ; list of the required arguments
+ optional-args ; list of the optional arguments
+ key-p ; whether &key appeared
+ keyword-args ; list of the keywords
+ rest ; name of the &rest or &body argument (if any)
+ body-p ; whether the rest argument is a &body
+ allow-other-keys-p ; whether &allow-other-keys appeared
+ aux-args ; list of &aux variables
+ any-p ; whether &any appeared
+ any-args ; list of &any arguments [*]
+ known-junk ; &whole, &environment
+ unknown-junk) ; unparsed stuff
+
+;;;
+;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp,
+;;; and is only used to describe certain arglists that cannot be
+;;; described in another way.
+;;;
+;;; &ANY is very similiar to &KEY but while &KEY is based upon
+;;; the idea of a plist (key1 value1 key2 value2), &ANY is a
+;;; cross between &OPTIONAL, &KEY and *FEATURES* lists:
+;;;
+;;; a) (&ANY :A :B :C) means that you can provide any (non-null)
+;;; set consisting of the keywords `:A', `:B', or `:C' in
+;;; the arglist. E.g. (:A) or (:C :B :A).
+;;;
+;;; (This is not restricted to keywords only, but any self-evaluating
+;;; expression is allowed.)
+;;;
+;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can
+;;; provide any (non-null) set consisting of lists where
+;;; the CAR of the list is one of `key1', `key2', or `key3'.
+;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23))
+;;;
+;;;
+;;; For example, a) let us describe the situations of EVAL-WHEN as
+;;;
+;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body)
+;;;
+;;; and b) let us describe the optimization qualifiers that are valid
+;;; in the declaration specifier `OPTIMIZE':
+;;;
+;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...))
+;;;
+
+;; FIXME: This really ought to be rewritten.
+(defun print-arglist (arglist &key operator highlight)
+ (let ((index 0)
+ (need-space nil))
+ (labels ((print-arg (arg)
+ (typecase arg
+ (arglist ; destructuring pattern
+ (print-arglist arg))
+ (optional-arg
+ (let ((enc-arg (encode-optional-arg arg)))
+ (if (symbolp enc-arg)
+ (princ enc-arg)
+ (destructuring-bind (var &optional (initform nil initform-p)) enc-arg
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (format t "~A~:[~; ~S~]" var initform-p initform))))))
+ (keyword-arg
+ (let ((enc-arg (encode-keyword-arg arg)))
+ (etypecase enc-arg
+ (symbol (princ enc-arg))
+ ((cons symbol)
+ (destructuring-bind (keyarg initform) enc-arg
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (format t "~A ~S" keyarg initform))))
+ ((cons cons)
+ (destructuring-bind ((keyword-name var) &optional (initform nil initform-p))
+ enc-arg
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (format t "~S ~A" keyword-name var))
+ (when initform-p
+ (format t " ~S" initform))))))))
+ (t ; required formal or provided actual arg
+ (if (keywordp arg)
+ (prin1 arg) ; for &ANY args.
+ (princ arg)))))
+ (print-space ()
+ (ecase need-space
+ ((nil))
+ ((:miser)
+ (write-char #\space)
+ (pprint-newline :miser))
+ ((t)
+ (write-char #\space)
+ (pprint-newline :fill)))
+ (setq need-space t))
+ (print-with-space (obj)
+ (print-space)
+ (print-arg obj))
+ (print-with-highlight (arg &optional (index-ok-p #'=))
+ (print-space)
+ (cond
+ ((and highlight (funcall index-ok-p index highlight))
+ (princ "===> ")
+ (print-arg arg)
+ (princ " <==="))
+ (t
+ (print-arg arg)))
+ (incf index)))
+ (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+ (when operator
+ (print-with-highlight operator)
+ (setq need-space :miser))
+ (mapc #'print-with-highlight
+ (arglist.provided-args arglist))
+ (mapc #'print-with-highlight
+ (arglist.required-args arglist))
+ (when (arglist.optional-args arglist)
+ (print-with-space '&optional)
+ (mapc #'print-with-highlight
+ (arglist.optional-args arglist)))
+ (when (arglist.key-p arglist)
+ (print-with-space '&key)
+ (mapc #'print-with-space
+ (arglist.keyword-args arglist)))
+ (when (arglist.allow-other-keys-p arglist)
+ (print-with-space '&allow-other-keys))
+ (when (arglist.any-args arglist)
+ (print-with-space '&any)
+ (mapc #'print-with-space
+ (arglist.any-args arglist)))
+ (cond ((not (arglist.rest arglist)))
+ ((arglist.body-p arglist)
+ (print-with-space '&body)
+ (print-with-highlight (arglist.rest arglist) #'<=))
+ (t
+ (print-with-space '&rest)
+ (print-with-highlight (arglist.rest arglist) #'<=)))
+ (mapc #'print-with-space
+ (arglist.unknown-junk arglist))))))
+
+(defvar *arglist-pprint-bindings*
+ '((*print-case* . :downcase)
+ (*print-pretty* . t)
+ (*print-circle* . nil)
+ (*print-readably* . nil)
+ (*print-level* . 10)
+ (*print-length* . 20)
+ (*print-escape* . nil))) ; no package qualifiers.
+
+(defun decoded-arglist-to-string (arglist
+ &key operator highlight (package *package*)
+ print-right-margin print-lines)
+ "Print the decoded ARGLIST for display in the echo area. The
+argument name are printed without package qualifiers and pretty
+printing of (function foo) as #'foo is suppressed. If HIGHLIGHT is
+non-nil, it must be the index of an argument; highlight this argument.
+If OPERATOR is non-nil, put it in front of the arglist."
+ (with-output-to-string (*standard-output*)
+ (with-standard-io-syntax
+ (with-bindings *arglist-pprint-bindings*
+ (let ((*package* package)
+ (*print-right-margin* print-right-margin)
+ (*print-lines* print-lines))
+ (print-arglist arglist :operator operator :highlight highlight))))))
+
+(defslimefun variable-desc-for-echo-area (variable-name)
+ "Return a short description of VARIABLE-NAME, or NIL."
+ (with-buffer-syntax ()
+ (let ((sym (parse-symbol variable-name)))
+ (if (and sym (boundp sym))
+ (let ((*print-pretty* nil) (*print-level* 4)
+ (*print-length* 10) (*print-circle* t))
+ (format nil "~A => ~A" sym (symbol-value sym)))))))
+
+(defun decode-required-arg (arg)
+ "ARG can be a symbol or a destructuring pattern."
+ (etypecase arg
+ (symbol arg)
+ (list (decode-arglist arg))))
+
+(defun encode-required-arg (arg)
+ (etypecase arg
+ (symbol arg)
+ (arglist (encode-arglist arg))))
+
+(defstruct (keyword-arg
+ (:conc-name keyword-arg.)
+ (:constructor make-keyword-arg (keyword arg-name default-arg)))
+ keyword
+ arg-name
+ default-arg)
+
+(defun decode-keyword-arg (arg)
+ "Decode a keyword item of formal argument list.
+Return three values: keyword, argument name, default arg."
+ (cond ((symbolp arg)
+ (make-keyword-arg (intern (symbol-name arg) keyword-package)
+ arg
+ nil))
+ ((and (consp arg)
+ (consp (car arg)))
+ (make-keyword-arg (caar arg)
+ (decode-required-arg (cadar arg))
+ (cadr arg)))
+ ((consp arg)
+ (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
+ (car arg)
+ (cadr arg)))
+ (t
+ (error "Bad keyword item of formal argument list"))))
+
+(defun encode-keyword-arg (arg)
+ (cond
+ ((arglist-p (keyword-arg.arg-name arg))
+ ;; Destructuring pattern
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (encode-required-arg
+ (keyword-arg.arg-name arg)))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))
+ ((eql (intern (symbol-name (keyword-arg.arg-name arg))
+ keyword-package)
+ (keyword-arg.keyword arg))
+ (if (keyword-arg.default-arg arg)
+ (list (keyword-arg.arg-name arg)
+ (keyword-arg.default-arg arg))
+ (keyword-arg.arg-name arg)))
+ (t
+ (let ((keyword/name (list (keyword-arg.keyword arg)
+ (keyword-arg.arg-name arg))))
+ (if (keyword-arg.default-arg arg)
+ (list keyword/name
+ (keyword-arg.default-arg arg))
+ (list keyword/name))))))
+
+(progn
+ (assert (equalp (decode-keyword-arg 'x)
+ (make-keyword-arg :x 'x nil)))
+ (assert (equalp (decode-keyword-arg '(x t))
+ (make-keyword-arg :x 'x t)))
+ (assert (equalp (decode-keyword-arg '((:x y)))
+ (make-keyword-arg :x 'y nil)))
+ (assert (equalp (decode-keyword-arg '((:x y) t))
+ (make-keyword-arg :x 'y t))))
+
+(defstruct (optional-arg
+ (:conc-name optional-arg.)
+ (:constructor make-optional-arg (arg-name default-arg)))
+ arg-name
+ default-arg)
+
+(defun decode-optional-arg (arg)
+ "Decode an optional item of a formal argument list.
+Return an OPTIONAL-ARG structure."
+ (etypecase arg
+ (symbol (make-optional-arg arg nil))
+ (list (make-optional-arg (decode-required-arg (car arg))
+ (cadr arg)))))
+
+(defun encode-optional-arg (optional-arg)
+ (if (or (optional-arg.default-arg optional-arg)
+ (arglist-p (optional-arg.arg-name optional-arg)))
+ (list (encode-required-arg
+ (optional-arg.arg-name optional-arg))
+ (optional-arg.default-arg optional-arg))
+ (optional-arg.arg-name optional-arg)))
+
+(progn
+ (assert (equalp (decode-optional-arg 'x)
+ (make-optional-arg 'x nil)))
+ (assert (equalp (decode-optional-arg '(x t))
+ (make-optional-arg 'x t))))
+
+(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
+
+(defun decode-arglist (arglist)
+ "Parse the list ARGLIST and return an ARGLIST structure."
+ (let ((mode nil)
+ (result (make-arglist)))
+ (dolist (arg arglist)
+ (cond
+ ((eql mode '&unknown-junk)
+ ;; don't leave this mode -- we don't know how the arglist
+ ;; after unknown lambda-list keywords is interpreted
+ (push arg (arglist.unknown-junk result)))
+ ((eql arg '&allow-other-keys)
+ (setf (arglist.allow-other-keys-p result) t))
+ ((eql arg '&key)
+ (setf (arglist.key-p result) t
+ mode arg))
+ ((member arg '(&optional &rest &body &aux))
+ (setq mode arg))
+ ((member arg '(&whole &environment))
+ (setq mode arg)
+ (push arg (arglist.known-junk result)))
+ ((and (symbolp arg)
+ (string= (symbol-name arg) (string '#:&any))) ; may be interned
+ (setf (arglist.any-p result) t) ; in any *package*.
+ (setq mode '&any))
+ ((member arg lambda-list-keywords)
+ (setq mode '&unknown-junk)
+ (push arg (arglist.unknown-junk result)))
+ (t
+ (ecase mode
+ (&key
+ (push (decode-keyword-arg arg)
+ (arglist.keyword-args result)))
+ (&optional
+ (push (decode-optional-arg arg)
+ (arglist.optional-args result)))
+ (&body
+ (setf (arglist.body-p result) t
+ (arglist.rest result) arg))
+ (&rest
+ (setf (arglist.rest result) arg))
+ (&aux
+ (push (decode-optional-arg arg)
+ (arglist.aux-args result)))
+ ((nil)
+ (push (decode-required-arg arg)
+ (arglist.required-args result)))
+ ((&whole &environment)
+ (setf mode nil)
+ (push arg (arglist.known-junk result)))
+ (&any
+ (push arg (arglist.any-args result)))))))
+ (nreversef (arglist.required-args result))
+ (nreversef (arglist.optional-args result))
+ (nreversef (arglist.keyword-args result))
+ (nreversef (arglist.aux-args result))
+ (nreversef (arglist.any-args result))
+ (nreversef (arglist.known-junk result))
+ (nreversef (arglist.unknown-junk result))
+ (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result)))
+ (exactly-one-p (arglist.key-p result) (arglist.any-p result))))
+ result))
+
+(defun encode-arglist (decoded-arglist)
+ (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
+ (when (arglist.optional-args decoded-arglist)
+ '(&optional))
+ (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
+ (when (arglist.key-p decoded-arglist)
+ '(&key))
+ (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
+ (when (arglist.allow-other-keys-p decoded-arglist)
+ '(&allow-other-keys))
+ (when (arglist.any-args decoded-arglist)
+ `(&any ,(a)(arglist.any-args decoded-arglist)))
+ (cond ((not (arglist.rest decoded-arglist))
+ '())
+ ((arglist.body-p decoded-arglist)
+ `(&body ,(arglist.rest decoded-arglist)))
+ (t
+ `(&rest ,(arglist.rest decoded-arglist))))
+ (when (arglist.aux-args decoded-arglist)
+ `(&aux ,(arglist.aux-args decoded-arglist)))
+ (arglist.known-junk decoded-arglist)
+ (arglist.unknown-junk decoded-arglist)))
+
+(defun arglist-keywords (arglist)
+ "Return the list of keywords in ARGLIST.
+As a secondary value, return whether &allow-other-keys appears."
+ (let ((decoded-arglist (decode-arglist arglist)))
+ (values (arglist.keyword-args decoded-arglist)
+ (arglist.allow-other-keys-p decoded-arglist))))
+
+(defun methods-keywords (methods)
+ "Collect all keywords in the arglists of METHODS.
+As a secondary value, return whether &allow-other-keys appears somewhere."
+ (let ((keywords '())
+ (allow-other-keys nil))
+ (dolist (method methods)
+ (multiple-value-bind (kw aok)
+ (arglist-keywords
+ (swank-mop:method-lambda-list method))
+ (setq keywords (remove-duplicates (append keywords kw)
+ :key #'keyword-arg.keyword)
+ allow-other-keys (or allow-other-keys aok))))
+ (values keywords allow-other-keys)))
+
+(defun generic-function-keywords (generic-function)
+ "Collect all keywords in the methods of GENERIC-FUNCTION.
+As a secondary value, return whether &allow-other-keys appears somewhere."
+ (methods-keywords
+ (swank-mop:generic-function-methods generic-function)))
+
+(defun applicable-methods-keywords (generic-function arguments)
+ "Collect all keywords in the methods of GENERIC-FUNCTION that are
+applicable for argument of CLASSES. As a secondary value, return
+whether &allow-other-keys appears somewhere."
+ (methods-keywords
+ (multiple-value-bind (amuc okp)
+ (swank-mop:compute-applicable-methods-using-classes
+ generic-function (mapcar #'class-of arguments))
+ (if okp
+ amuc
+ (compute-applicable-methods generic-function arguments)))))
+
+(defun decoded-arglist-to-template-string (decoded-arglist package &key (prefix "(") (suffix ")"))
+ (with-output-to-string (*standard-output*)
+ (with-standard-io-syntax
+ (let ((*package* package) (*print-case* :downcase)
+ (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
+ (*print-level* 10) (*print-length* 20))
+ (print-decoded-arglist-as-template decoded-arglist
+ :prefix prefix
+ :suffix suffix)))))
+
+(defun print-decoded-arglist-as-template (decoded-arglist &key
+ (prefix "(") (suffix ")"))
+ (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
+ (let ((first-p t))
+ (flet ((space ()
+ (unless first-p
+ (write-char #\space)
+ (pprint-newline :fill))
+ (setq first-p nil))
+ (print-arg-or-pattern (arg)
+ (etypecase arg
+ (symbol (if (keywordp arg) (prin1 arg) (princ arg)))
+ (string (princ arg))
+ (list (princ arg))
+ (arglist (print-decoded-arglist-as-template arg)))))
+ (dolist (arg (arglist.required-args decoded-arglist))
+ (space)
+ (print-arg-or-pattern arg))
+ (dolist (arg (arglist.optional-args decoded-arglist))
+ (space)
+ (princ "[")
+ (print-arg-or-pattern (optional-arg.arg-name arg))
+ (princ "]"))
+ (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
+ (space)
+ (let ((arg-name (keyword-arg.arg-name keyword-arg))
+ (keyword (keyword-arg.keyword keyword-arg)))
+ (format t "~W "
+ (if (keywordp keyword) keyword `',keyword))
+ (print-arg-or-pattern arg-name)))
+ (dolist (any-arg (arglist.any-args decoded-arglist))
+ (space)
+ (print-arg-or-pattern any-arg))
+ (when (and (arglist.rest decoded-arglist)
+ (or (not (arglist.keyword-args decoded-arglist))
+ (arglist.allow-other-keys-p decoded-arglist)))
+ (if (arglist.body-p decoded-arglist)
+ (pprint-newline :mandatory)
+ (space))
+ (format t "~A..." (arglist.rest decoded-arglist)))))
+ (pprint-newline :fill)))
+
+
+(defgeneric extra-keywords (operator &rest args)
+ (:documentation "Return a list of extra keywords of OPERATOR (a
+symbol) when applied to the (unevaluated) ARGS.
+As a secondary value, return whether other keys are allowed.
+As a tertiary value, return the initial sublist of ARGS that was needed
+to determine the extra keywords."))
+
+(defun keywords-of-operator (operator)
+ "Return a list of KEYWORD-ARGs that OPERATOR accepts.
+This function is useful for writing EXTRA-KEYWORDS methods for
+user-defined functions which are declared &ALLOW-OTHER-KEYS and which
+forward keywords to OPERATOR."
+ (let ((arglist (arglist-from-form-spec (ensure-list operator)
+ :remove-args nil)))
+ (unless (eql arglist :not-available)
+ (values
+ (arglist.keyword-args arglist)
+ (arglist.allow-other-keys-p arglist)))))
+
+(defmethod extra-keywords (operator &rest args)
+ ;; default method
+ (declare (ignore args))
+ (let ((symbol-function (symbol-function operator)))
+ (if (typep symbol-function 'generic-function)
+ (generic-function-keywords symbol-function)
+ nil)))
+
+(defun class-from-class-name-form (class-name-form)
+ (when (and (listp class-name-form)
+ (= (length class-name-form) 2)
+ (eq (car class-name-form) 'quote))
+ (let* ((class-name (cadr class-name-form))
+ (class (find-class class-name nil)))
+ (when (and class
+ (not (swank-mop:class-finalized-p class)))
+ ;; Try to finalize the class, which can fail if
+ ;; superclasses are not defined yet
+ (handler-case (swank-mop:finalize-inheritance class)
+ (program-error (c)
+ (declare (ignore c)))))
+ class)))
+
+(defun extra-keywords/slots (class)
+ (multiple-value-bind (slots allow-other-keys-p)
+ (if (swank-mop:class-finalized-p class)
+ (values (swank-mop:class-slots class) nil)
+ (values (swank-mop:class-direct-slots class) t))
+ (let ((slot-init-keywords
+ (loop for slot in slots append
+ (mapcar (lambda (initarg)
+ (make-keyword-arg
+ initarg
+ (swank-mop:slot-definition-name slot)
+ (swank-mop:slot-definition-initform slot)))
+ (swank-mop:slot-definition-initargs slot)))))
+ (values slot-init-keywords allow-other-keys-p))))
+
+(defun extra-keywords/make-instance (operator &rest args)
+ (declare (ignore operator))
+ (unless (null args)
+ (let* ((class-name-form (car args))
+ (class (class-from-class-name-form class-name-form)))
+ (when class
+ (multiple-value-bind (slot-init-keywords class-aokp)
+ (extra-keywords/slots class)
+ (multiple-value-bind (allocate-instance-keywords ai-aokp)
+ (applicable-methods-keywords
+ #'allocate-instance (list class))
+ (multiple-value-bind (initialize-instance-keywords ii-aokp)
+ (applicable-methods-keywords
+ #'initialize-instance (list (swank-mop:class-prototype class)))
+ (multiple-value-bind (shared-initialize-keywords si-aokp)
+ (applicable-methods-keywords
+ #'shared-initialize (list (swank-mop:class-prototype class) t))
+ (values (append slot-init-keywords
+ allocate-instance-keywords
+ initialize-instance-keywords
+ shared-initialize-keywords)
+ (or class-aokp ai-aokp ii-aokp si-aokp)
+ (list class-name-form))))))))))
+
+(defun extra-keywords/change-class (operator &rest args)
+ (declare (ignore operator))
+ (unless (null args)
+ (let* ((class-name-form (car args))
+ (class (class-from-class-name-form class-name-form)))
+ (when class
+ (multiple-value-bind (slot-init-keywords class-aokp)
+ (extra-keywords/slots class)
+ (declare (ignore class-aokp))
+ (multiple-value-bind (shared-initialize-keywords si-aokp)
+ (applicable-methods-keywords
+ #'shared-initialize (list (swank-mop:class-prototype class) t))
+ ;; FIXME: much as it would be nice to include the
+ ;; applicable keywords from
+ ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
+ ;; how to do it: so we punt, always declaring
+ ;; &ALLOW-OTHER-KEYS.
+ (declare (ignore si-aokp))
+ (values (append slot-init-keywords shared-initialize-keywords)
+ t
+ (list class-name-form))))))))
+
+(defmacro multiple-value-or (&rest forms)
+ (if (null forms)
+ nil
+ (let ((first (first forms))
+ (rest (rest forms)))
+ `(let* ((values (multiple-value-list ,first))
+ (primary-value (first values)))
+ (if primary-value
+ (values-list values)
+ (multiple-value-or ,@rest))))))
+
+(defmethod extra-keywords ((operator (eql 'make-instance))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'make-condition))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'error))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'signal))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'warn))
+ &rest args)
+ (multiple-value-or (apply #'extra-keywords/make-instance operator args)
+ (call-next-method)))
+
+(defmethod extra-keywords ((operator (eql 'cerror))
+ &rest args)
+ (multiple-value-bind (keywords aok determiners)
+ (apply #'extra-keywords/make-instance operator
+ (cdr args))
+ (if keywords
+ (values keywords aok
+ (cons (car args) determiners))
+ (call-next-method))))
+
+(defmethod extra-keywords ((operator (eql 'change-class))
+ &rest args)
+ (multiple-value-bind (keywords aok determiners)
+ (apply #'extra-keywords/change-class operator (cdr args))
+ (if keywords
+ (values keywords aok
+ (cons (car args) determiners))
+ (call-next-method))))
+
+(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
+ "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
+ (when keywords
+ (setf (arglist.key-p decoded-arglist) t)
+ (setf (arglist.keyword-args decoded-arglist)
+ (remove-duplicates
+ (append (arglist.keyword-args decoded-arglist)
+ keywords)
+ :key #'keyword-arg.keyword)))
+ (setf (arglist.allow-other-keys-p decoded-arglist)
+ (or (arglist.allow-other-keys-p decoded-arglist)
+ allow-other-keys-p)))
+
+(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form)
+ "Determine extra keywords from the function call FORM, and modify
+DECODED-ARGLIST to include them. As a secondary return value, return
+the initial sublist of ARGS that was needed to determine the extra
+keywords. As a tertiary return value, return whether any enrichment
+was done."
+ (multiple-value-bind (extra-keywords extra-aok determining-args)
+ (apply #'extra-keywords form)
+ ;; enrich the list of keywords with the extra keywords
+ (enrich-decoded-arglist-with-keywords decoded-arglist
+ extra-keywords extra-aok)
+ (values decoded-arglist
+ determining-args
+ (or extra-keywords extra-aok))))
+
+(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms)
+ (:documentation
+ "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and
+ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords.
+If the arglist is not available, return :NOT-AVAILABLE."))
+
+(defmethod compute-enriched-decoded-arglist (operator-form argument-forms)
+ (let ((arglist (arglist operator-form)))
+ (etypecase arglist
+ ((member :not-available)
+ :not-available)
+ (list
+ (let ((decoded-arglist (decode-arglist arglist)))
+ (enrich-decoded-arglist-with-extra-keywords decoded-arglist
+ (cons operator-form
+ argument-forms)))))))
+
+(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
+ argument-forms)
+ (declare (ignore argument-forms))
+ (multiple-value-bind (decoded-arglist determining-args)
+ (call-next-method)
+ (let ((first-arg (first (arglist.required-args decoded-arglist)))
+ (open-arglist (compute-enriched-decoded-arglist 'open nil)))
+ (when (and (arglist-p first-arg) (arglist-p open-arglist))
+ (enrich-decoded-arglist-with-keywords
+ first-arg
+ (arglist.keyword-args open-arglist)
+ nil)))
+ (values decoded-arglist determining-args t)))
+
+(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply))
+ argument-forms)
+ (let ((function-name-form (car argument-forms)))
+ (when (and (listp function-name-form)
+ (length= function-name-form 2)
+ (member (car function-name-form) '(quote function)))
+ (let ((function-name (cadr function-name-form)))
+ (when (valid-operator-symbol-p function-name)
+ (let ((function-arglist
+ (compute-enriched-decoded-arglist function-name
+ (cdr argument-forms))))
+ (return-from compute-enriched-decoded-arglist
+ (values (make-arglist :required-args
+ (list 'function)
+ :optional-args
+ (append
+ (mapcar #'(lambda (arg)
+ (make-optional-arg arg nil))
+ (arglist.required-args function-arglist))
+ (arglist.optional-args function-arglist))
+ :key-p
+ (arglist.key-p function-arglist)
+ :keyword-args
+ (arglist.keyword-args function-arglist)
+ :rest
+ 'args
+ :allow-other-keys-p
+ (arglist.allow-other-keys-p function-arglist))
+ (list function-name-form)
+ t)))))))
+ (call-next-method))
+
+(defvar *remove-keywords-alist*
+ '((:test :test-not)
+ (:test-not :test)))
+
+(defun remove-actual-args (decoded-arglist actual-arglist)
+ "Remove from DECODED-ARGLIST the arguments that have already been
+provided in ACTUAL-ARGLIST."
+ (assert (or (and (not (arglist.key-p decoded-arglist))
+ (not (arglist.any-p decoded-arglist)))
+ (exactly-one-p (arglist.key-p decoded-arglist)
+ (arglist.any-p decoded-arglist))))
+ (loop while (and actual-arglist
+ (arglist.required-args decoded-arglist))
+ do (progn (pop actual-arglist)
+ (pop (arglist.required-args decoded-arglist))))
+ (loop while (and actual-arglist
+ (arglist.optional-args decoded-arglist))
+ do (progn (pop actual-arglist)
+ (pop (arglist.optional-args decoded-arglist))))
+ (if (arglist.any-p decoded-arglist)
+ (remove-&any-args decoded-arglist actual-arglist)
+ (remove-&key-args decoded-arglist actual-arglist))
+ decoded-arglist)
+
+(defun remove-&key-args (decoded-arglist key-args)
+ (loop for keyword in key-args by #'cddr
+ for keywords-to-remove = (cdr (assoc keyword *remove-keywords-alist*))
+ do (setf (arglist.keyword-args decoded-arglist)
+ (remove-if (lambda (kw)
+ (or (eql kw keyword)
+ (member kw keywords-to-remove)))
+ (arglist.keyword-args decoded-arglist)
+ :key #'keyword-arg.keyword))) )
+
+(defun remove-&any-args (decoded-arglist any-args)
+ (setf (arglist.any-args decoded-arglist)
+ (remove-if #'(lambda (x) (member x any-args))
+ (arglist.any-args decoded-arglist)
+ :key #'(lambda (x) (first (ensure-list x))))))
+
+
+(defun arglist-from-form-spec (form-spec &key (remove-args t))
+ "Returns the decoded arglist that corresponds to FORM-SPEC. If
+REMOVE-ARGS is T, the arguments that are contained in FORM-SPEC
+are removed from the result arglist.
+
+Examples:
+
+ (arglist-from-form-spec '(defun))
+
+ ~=> (name args &body body)
+
+ (arglist-from-form-spec '(defun foo))
+
+ ~=> (args &body body)
+
+ (arglist-from-form-spec '(defun foo) :remove-args nil))
+
+ ~=> (name args &body body))
+
+ (arglist-from-form-spec '((:type-specifier float) 42) :remove-args nil)
+
+ ~=> (&optional lower-limit upper-limit)
+"
+ (if (null form-spec)
+ :not-available
+ (multiple-value-bind (type operator arguments)
+ (split-form-spec form-spec)
+ (arglist-dispatch type operator arguments :remove-args remove-args))))
+
+(defmacro with-availability ((var) form &body body)
+ `(let ((,var ,form))
+ (if (eql ,var :not-available)
+ :not-available
+ (progn ,@body))))
+
+(defgeneric arglist-dispatch (operator-type operator arguments &key remove-args))
+
+(defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t))
+ (when (and (symbolp operator)
+ (valid-operator-symbol-p operator))
+ (multiple-value-bind (decoded-arglist determining-args any-enrichment)
+ (compute-enriched-decoded-arglist operator arguments)
+ (etypecase decoded-arglist
+ ((member :not-available)
+ :not-available)
+ (arglist
+ (cond
+ (remove-args
+ ;; get rid of formal args already provided
+ (remove-actual-args decoded-arglist arguments))
+ (t
+ ;; replace some formal args by determining actual args
+ (remove-actual-args decoded-arglist determining-args)
+ (setf (arglist.provided-args decoded-arglist)
+ determining-args)))
+ (return-from arglist-dispatch
+ (values decoded-arglist any-enrichment))))))
+ :not-available)
+
+(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'defmethod))
+ arguments &key (remove-args t))
+ (when (and (listp arguments)
+ (not (null arguments)) ;have generic function name
+ (notany #'listp (rest arguments))) ;don't have arglist yet
+ (let* ((gf-name (first arguments))
+ (gf (and (valid-function-name-p gf-name)
+ (fboundp gf-name)
+ (fdefinition gf-name))))
+ (when (typep gf 'generic-function)
+ (with-availability (arglist) (arglist gf)
+ (return-from arglist-dispatch
+ (values (make-arglist :provided-args (if remove-args
+ nil
+ (list gf-name))
+ :required-args (list arglist)
+ :rest "body" :body-p t)
+ t))))))
+ (call-next-method))
+
+(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'eval-when))
+ arguments &key (remove-args t))
+ (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute)))
+ (make-arglist :required-args (list (maybecall remove-args #'remove-actual-args
+ (make-arglist :any-args eval-when-args)
+ arguments))
+ :rest '#:body :body-p t)))
+
+(defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'declare))
+ arguments &key (remove-args t))
+ ;; Catching 'DECLARE before SWANK-BACKEND:ARGLIST can barf.
+ (declare (ignore remove-args))
+ (make-arglist :rest '#:decl-specifiers))
+
+(defmethod arglist-dispatch ((operator-type (eql :declaration))
+ decl-identifier decl-args &key (remove-args t))
+ (with-availability (arglist)
+ (declaration-arglist decl-identifier)
+ (maybecall remove-args #'remove-actual-args
+ (decode-arglist arglist) decl-args))
+ ;; We don't fall back to CALL-NEXT-METHOD because we're within a
+ ;; different namespace!
+ )
+
+(defmethod arglist-dispatch ((operator-type (eql :type-specifier))
+ type-specifier specifier-args &key (remove-args t))
+ (with-availability (arglist)
+ (type-specifier-arglist type-specifier)
+ (maybecall remove-args #'remove-actual-args
+ (decode-arglist arglist) specifier-args))
+ ;; No CALL-NEXT-METHOD, see above.
+ )
+
+
+(defun read-incomplete-form-from-string (form-string)
+ (with-buffer-syntax ()
+ (call-with-ignored-reader-errors
+ #'(lambda ()
+ (read-from-string form-string)))))
+
+(defun call-with-ignored-reader-errors (thunk)
+ (declare (type (function () (values &rest t)) thunk))
+ (declare (optimize (speed 3) (safety 1)))
+ (handler-case (funcall thunk)
+ (reader-error (c)
+ (declare (ignore c))
+ nil)
+ (stream-error (c)
+ (declare (ignore c))
+ nil)))
+
+(defslimefun complete-form (form-string)
+ "Read FORM-STRING in the current buffer package, then complete it
+by adding a template for the missing arguments."
+ (multiple-value-bind (form newly-interned-symbols)
+ (parse-form-spec form-string)
+ (unwind-protect
+ (when (consp form)
+ (let ((form-completion (arglist-from-form-spec form)))
+ (unless (eql form-completion :not-available)
+ (return-from complete-form
+ (decoded-arglist-to-template-string form-completion
+ *buffer-package*
+ :prefix "")))))
+ (mapc #'unintern-in-home-package newly-interned-symbols))
+ :not-available))
+
+
+(defun arglist-ref (decoded-arglist operator &rest indices)
+ (cond
+ ((null indices) decoded-arglist)
+ ((not (arglist-p decoded-arglist)) nil)
+ (t
+ (let ((index (first indices))
+ (args (append (and operator
+ (list operator))
+ (arglist.required-args decoded-arglist)
+ (arglist.optional-args decoded-arglist))))
+ (when (< index (length args))
+ (let ((arg (elt args index)))
+ (apply #'arglist-ref arg nil (rest indices))))))))
+
+(defslimefun completions-for-keyword (raw-specs keyword-string arg-index-specs)
+ (with-buffer-syntax ()
+ (multiple-value-bind (form-spec position newly-interned-symbols)
+ (parse-first-valid-form-spec raw-specs)
+ (unwind-protect
+ (when form-spec
+ (let ((arglist (arglist-from-form-spec form-spec :remove-args nil)))
+ (unless (eql arglist :not-available)
+ (let* ((operator (nth-value 1 (split-form-spec form-spec)))
+ (indices (reverse (rest (subseq arg-index-specs 0 (1+ position)))))
+ (arglist (apply #'arglist-ref arglist operator indices)))
+ (when (and arglist (arglist-p arglist))
+ ;; It would be possible to complete keywords only if we
+ ;; are in a keyword position, but it is not clear if we
+ ;; want that.
+ (let* ((keywords
+ (append (mapcar #'keyword-arg.keyword
+ (arglist.keyword-args arglist))
+ (remove-if-not #'keywordp (arglist.any-args arglist))))
+ (keyword-name
+ (tokenize-symbol keyword-string))
+ (matching-keywords
+ (find-matching-symbols-in-list keyword-name keywords
+ #'compound-prefix-match))
+ (converter (completion-output-symbol-converter keyword-string))
+ (strings
+ (mapcar converter
+ (mapcar #'symbol-name matching-keywords)))
+ (completion-set
+ (format-completion-set strings nil "")))
+ (list completion-set
+ (longest-compound-prefix completion-set))))))))
+ (mapc #'unintern-in-home-package newly-interned-symbols)))))
+
+
+(defun arglist-to-string (arglist package &key print-right-margin highlight)
+ (decoded-arglist-to-string (decode-arglist arglist)
+ :package package
+ :print-right-margin print-right-margin
+ :highlight highlight))
+
+(defun test-print-arglist ()
+ (flet ((test (list string)
+ (let* ((p (find-package :swank))
+ (actual (arglist-to-string list p)))
+ (unless (string= actual string)
+ (warn "Test failed: ~S => ~S~% Expected: ~S"
+ list actual string)))))
+ (test '(function cons) "(function cons)")
+ (test '(quote cons) "(quote cons)")
+ (test '(&key (function #'+)) "(&key (function #'+))")
+ (test '(&whole x y z) "(y z)")
+ (test '(x &aux y z) "(x)")
+ (test '(x &environment env y) "(x y)")
+ (test '(&key ((function f))) "(&key ((function f)))")
+ (test '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)
+ "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)")
+ (test '(declare (optimize &any (speed 1) (safety 1)))
+ "(declare (optimize &any (speed 1) (safety 1)))")
+ ))
+
+(test-print-arglist)
+
+(provide :swank-arglists)
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-asdf.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-asdf.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,63 @@
+;;; swank-asdf.el -- ASDF support
+;;
+;; Authors: Daniel Barlow <dan(a)telent.net>
+;; Marco Baringer <mb(a)bese.it>
+;; Edi Weitz <edi(a)agharta.de>
+;; and others
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+(defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
+ "Compile and load SYSTEM using ASDF.
+Record compiler notes signalled as `compiler-condition's."
+ (swank-compiler
+ (lambda ()
+ (apply #'operate-on-system system-name operation keywords))))
+
+(defun operate-on-system (system-name operation-name &rest keyword-args)
+ "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
+The KEYWORD-ARGS are passed on to the operation.
+Example:
+\(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"
+ (with-compilation-hooks ()
+ (let ((operation (find-symbol operation-name :asdf)))
+ (when (null operation)
+ (error "Couldn't find ASDF operation ~S" operation-name))
+ (apply #'asdf:operate operation system-name keyword-args))))
+
+(defun asdf-central-registry ()
+ asdf:*central-registry*)
+
+(defslimefun list-all-systems-in-central-registry ()
+ "Returns a list of all systems in ASDF's central registry."
+ (mapcar #'pathname-name
+ (delete-duplicates
+ (loop for dir in (asdf-central-registry)
+ for defaults = (eval dir)
+ when defaults
+ nconc (mapcar #'file-namestring
+ (directory
+ (make-pathname :defaults defaults
+ :version :newest
+ :type "asd"
+ :name :wild
+ :case :local))))
+ :test #'string=)))
+
+(defslimefun list-all-systems-known-to-asdf ()
+ "Returns a list of all systems ASDF knows already."
+ ;; ugh, yeah, it's unexported - but do we really expect this to
+ ;; change anytime soon?
+ (loop for name being the hash-keys of asdf::*defined-systems*
+ collect name))
+
+(defslimefun list-asdf-systems ()
+ "Returns the systems in ASDF's central registry and those which ASDF
+already knows."
+ (nunion (list-all-systems-known-to-asdf)
+ (list-all-systems-in-central-registry)
+ :test #'string=))
+
+(provide :swank-asdf)
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-c-p-c.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-c-p-c.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,279 @@
+;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion
+;;
+;; Author: Luke Gorrie <luke(a)synap.se>
+;; Edi Weitz <edi(a)agharta.de>
+;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; and others
+;;
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+(defslimefun completions (string default-package-name)
+ "Return a list of completions for a symbol designator STRING.
+
+The result is the list (COMPLETION-SET COMPLETED-PREFIX), where
+COMPLETION-SET is the list of all matching completions, and
+COMPLETED-PREFIX is the best (partial) completion of the input
+string.
+
+Simple compound matching is supported on a per-hyphen basis:
+
+ (completions \"m-v-\" \"COMMON-LISP\")
+ ==> ((\"multiple-value-bind\" \"multiple-value-call\"
+ \"multiple-value-list\" \"multiple-value-prog1\"
+ \"multiple-value-setq\" \"multiple-values-limit\")
+ \"multiple-value\")
+
+\(For more advanced compound matching, see FUZZY-COMPLETIONS.)
+
+If STRING is package qualified the result list will also be
+qualified. If string is non-qualified the result strings are
+also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME.
+
+The way symbols are matched depends on the symbol designator's
+format. The cases are as follows:
+ FOO - Symbols with matching prefix and accessible in the buffer package.
+ PKG:FOO - Symbols with matching prefix and external in package PKG.
+ PKG::FOO - Symbols with matching prefix and accessible in package PKG.
+"
+ (let ((completion-set (completion-set string default-package-name
+ #'compound-prefix-match)))
+ (when completion-set
+ (list completion-set (longest-compound-prefix completion-set)))))
+
+;;;;; Find completion set
+
+(defun completion-set (string default-package-name matchp)
+ "Return the set of completion-candidates as strings."
+ (multiple-value-bind (name package-name package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (let* ((symbols (mapcar (completion-output-symbol-converter name)
+ (and package
+ (mapcar #'symbol-name
+ (find-matching-symbols name
+ package
+ (and (not internal-p)
+ package-name)
+ matchp)))))
+ (packs (mapcar (completion-output-package-converter name)
+ (and (not package-name)
+ (find-matching-packages name matchp)))))
+ (format-completion-set (nconc symbols packs) internal-p package-name))))
+
+(defun find-matching-symbols (string package external test)
+ "Return a list of symbols in PACKAGE matching STRING.
+TEST is called with two strings. If EXTERNAL is true, only external
+symbols are returned."
+ (let ((completions '())
+ (converter (completion-output-symbol-converter string)))
+ (flet ((symbol-matches-p (symbol)
+ (and (or (not external)
+ (symbol-external-p symbol package))
+ (funcall test string
+ (funcall converter (symbol-name symbol))))))
+ (do-symbols* (symbol package)
+ (when (symbol-matches-p symbol)
+ (push symbol completions))))
+ completions))
+
+(defun find-matching-symbols-in-list (string list test)
+ "Return a list of symbols in LIST matching STRING.
+TEST is called with two strings."
+ (let ((completions '())
+ (converter (completion-output-symbol-converter string)))
+ (flet ((symbol-matches-p (symbol)
+ (funcall test string
+ (funcall converter (symbol-name symbol)))))
+ (dolist (symbol list)
+ (when (symbol-matches-p symbol)
+ (push symbol completions))))
+ (remove-duplicates completions)))
+
+(defun find-matching-packages (name matcher)
+ "Return a list of package names matching NAME with MATCHER.
+MATCHER is a two-argument predicate."
+ (let ((to-match (string-upcase name)))
+ (remove-if-not (lambda (x) (funcall matcher to-match x))
+ (mapcar (lambda (pkgname)
+ (concatenate 'string pkgname ":"))
+ (loop for package in (list-all-packages)
+ collect (package-name package)
+ append (package-nicknames package))))))
+
+
+;; PARSE-COMPLETION-ARGUMENTS return table:
+;;
+;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
+;; ----------------+--------+--------------+-----------------------------------
+;; asdf [tab] | "asdf" | NIL | #<PACKAGE "DEFAULT-PACKAGE-NAME">
+;; | | | or *BUFFER-PACKAGE*
+;; asdf: [tab] | "" | "asdf" | #<PACKAGE "ASDF">
+;; | | |
+;; asdf:foo [tab] | "foo" | "asdf" | #<PACKAGE "ASDF">
+;; | | |
+;; as:fo [tab] | "fo" | "as" | NIL
+;; | | |
+;; : [tab] | "" | "" | #<PACKAGE "KEYWORD">
+;; | | |
+;; :foo [tab] | "foo" | "" | #<PACKAGE "KEYWORD">
+;;
+(defun parse-completion-arguments (string default-package-name)
+ "Parse STRING as a symbol designator.
+Return these values:
+ SYMBOL-NAME
+ PACKAGE-NAME, or nil if the designator does not include an explicit package.
+ PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is
+ NIL, return the respective package of DEFAULT-PACKAGE-NAME instead;
+ if PACKAGE is non-NIL but a package cannot be found under that name,
+ return NIL.)
+ INTERNAL-P, if the symbol is qualified with `::'."
+ (multiple-value-bind (name package-name internal-p)
+ (tokenize-symbol string)
+ (if package-name
+ (let ((package (guess-package (if (equal package-name "")
+ "KEYWORD"
+ package-name))))
+ (values name package-name package internal-p))
+ (let ((package (guess-package default-package-name)))
+ (values name package-name (or package *buffer-package*) internal-p))
+ )))
+
+
+
+(defun completion-output-case-converter (input &optional with-escaping-p)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+ (ecase (readtable-case *readtable*)
+ (:upcase (cond ((or with-escaping-p
+ (not (some #'lower-case-p input)))
+ #'identity)
+ (t #'string-downcase)))
+ (:invert (lambda (output)
+ (multiple-value-bind (lower upper) (determine-case output)
+ (cond ((and lower upper) output)
+ (lower (string-upcase output))
+ (upper (string-downcase output))
+ (t output)))))
+ (:downcase (cond ((or with-escaping-p
+ (not (some #'upper-case-p input)))
+ #'identity)
+ (t #'string-upcase)))
+ (:preserve #'identity)))
+
+(defun completion-output-package-converter (input)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case."
+ (completion-output-case-converter input))
+
+(defun completion-output-symbol-converter (input)
+ "Return a function to convert strings for the completion output.
+INPUT is used to guess the preferred case. Escape symbols when needed."
+ (let ((case-converter (completion-output-case-converter input))
+ (case-converter-with-escaping (completion-output-case-converter input t)))
+ (lambda (str)
+ (if (or (multiple-value-bind (lowercase uppercase)
+ (determine-case str)
+ ;; In these readtable cases, symbols with letters from
+ ;; the wrong case need escaping
+ (case (readtable-case *readtable*)
+ (:upcase lowercase)
+ (:downcase uppercase)
+ (t nil)))
+ (some (lambda (el)
+ (or (member el '(#\: #\Space #\Newline #\Tab))
+ (multiple-value-bind (macrofun nonterminating)
+ (get-macro-character el)
+ (and macrofun
+ (not nonterminating)))))
+ str))
+ (concatenate 'string "|" (funcall case-converter-with-escaping str) "|")
+ (funcall case-converter str)))))
+
+
+(defun determine-case (string)
+ "Return two booleans LOWER and UPPER indicating whether STRING
+contains lower or upper case characters."
+ (values (some #'lower-case-p string)
+ (some #'upper-case-p string)))
+
+
+;;;;; Compound-prefix matching
+
+(defun make-compound-prefix-matcher (delimeter &key (test #'char=))
+ "Returns a matching function that takes a `prefix' and a
+`target' string and which returns T if `prefix' is a
+compound-prefix of `target', and otherwise NIL.
+
+Viewing each of `prefix' and `target' as a series of substrings
+delimited by DELIMETER, if each substring of `prefix' is a prefix
+of the corresponding substring in `target' then we call `prefix'
+a compound-prefix of `target'."
+ (lambda (prefix target)
+ (declare (type simple-string prefix target))
+ (loop for ch across prefix
+ with tpos = 0
+ always (and (< tpos (length target))
+ (if (char= ch delimeter)
+ (setf tpos (position #\- target :start tpos))
+ (funcall test ch (aref target tpos))))
+ do (incf tpos))))
+
+(defun compound-prefix-match (prefix target)
+ "Examples:
+\(compound-prefix-match \"foo\" \"foobar\") => t
+\(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
+\(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL
+"
+ (funcall (make-compound-prefix-matcher #\-) prefix target))
+
+
+;;;;; Extending the input string by completion
+
+(defun longest-compound-prefix (completions &optional (delimeter #\-))
+ "Return the longest compound _prefix_ for all COMPLETIONS."
+ (flet ((tokenizer (string) (tokenize-completion string delimeter)))
+ (untokenize-completion
+ (loop for token-list in (transpose-lists (mapcar #'tokenizer completions))
+ if (notevery #'string= token-list (rest token-list))
+ collect (longest-common-prefix token-list) ; Note that we possibly collect
+ and do (loop-finish) ; the "" here as well, so that
+ else collect (first token-list))))) ; UNTOKENIZE-COMPLETION will
+ ; append a hyphen for us.
+(defun tokenize-completion (string delimeter)
+ "Return all substrings of STRING delimited by DELIMETER."
+ (loop with end
+ for start = 0 then (1+ end)
+ until (> start (length string))
+ do (setq end (or (position delimeter string :start start) (length string)))
+ collect (subseq string start end)))
+
+(defun untokenize-completion (tokens)
+ (format nil "~{~A~^-~}" tokens))
+
+(defun transpose-lists (lists)
+ "Turn a list-of-lists on its side.
+If the rows are of unequal length, truncate uniformly to the shortest.
+
+For example:
+\(transpose-lists '((ONE TWO THREE) (1 2)))
+ => ((ONE 1) (TWO 2))"
+ (cond ((null lists) '())
+ ((some #'null lists) '())
+ (t (cons (mapcar #'car lists)
+ (transpose-lists (mapcar #'cdr lists))))))
+
+
+;;;; Completion for character names
+
+(defslimefun completions-for-character (prefix)
+ (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal))
+ (completion-set (character-completion-set prefix matcher))
+ (completions (sort completion-set #'string<)))
+ (list completions (longest-compound-prefix completions #\_))))
+
+(provide :swank-c-p-c)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-fancy-inspector.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-fancy-inspector.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,737 @@
+;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects
+;;
+;; Author: Marco Baringer <mb(a)bese.it> and others
+;; License: Public Domain
+;;
+
+(in-package :swank)
+
+;; Subclass `backend-inspector' so that backend specific methods are
+;; also considered.
+(defclass fancy-inspector (backend-inspector) ())
+
+(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (let ((package (symbol-package symbol)))
+ (multiple-value-bind (_symbol status)
+ (and package (find-symbol (string symbol) package))
+ (declare (ignore _symbol))
+ (values
+ "A symbol."
+ (append
+ (label-value-line "Its name is" (symbol-name symbol))
+ ;;
+ ;; Value
+ (cond ((boundp symbol)
+ (label-value-line (if (constantp symbol)
+ "It is a constant of value"
+ "It is a global variable bound to")
+ (symbol-value symbol)))
+ (t '("It is unbound." (:newline))))
+ (docstring-ispec "Documentation" symbol 'variable)
+ (multiple-value-bind (expansion definedp) (macroexpand symbol)
+ (if definedp
+ (label-value-line "It is a symbol macro with expansion"
+ expansion)))
+ ;;
+ ;; Function
+ (if (fboundp symbol)
+ (append (if (macro-function symbol)
+ `("It a macro with macro-function: "
+ (:value ,(macro-function symbol)))
+ `("It is a function: "
+ (:value ,(symbol-function symbol))))
+ `(" " (:action "[make funbound]"
+ ,(lambda () (fmakunbound symbol))))
+ `((:newline)))
+ `("It has no function value." (:newline)))
+ (docstring-ispec "Function Documentation" symbol 'function)
+ (if (compiler-macro-function symbol)
+ (label-value-line "It also names the compiler macro"
+ (compiler-macro-function symbol)))
+ (docstring-ispec "Compiler Macro Documentation"
+ symbol 'compiler-macro)
+ ;;
+ ;; Package
+ (if package
+ `("It is " ,(string-downcase (string status))
+ " to the package: "
+ (:value ,package ,(package-name package))
+ ,@(if (eq :internal status)
+ `(" "
+ (:action "[export it]"
+ ,(lambda () (export symbol package)))))
+ " "
+ (:action "[unintern it]"
+ ,(lambda () (unintern symbol package)))
+ (:newline))
+ '("It is a non-interned symbol." (:newline)))
+ ;;
+ ;; Plist
+ (label-value-line "Property list" (symbol-plist symbol))
+ ;;
+ ;; Class
+ (if (find-class symbol nil)
+ `("It names the class "
+ (:value ,(find-class symbol) ,(string symbol))
+ " "
+ (:action "[remove]"
+ ,(lambda () (setf (find-class symbol) nil)))
+ (:newline)))
+ ;;
+ ;; More package
+ (if (find-package symbol)
+ (label-value-line "It names the package" (find-package symbol)))
+ )))))
+
+(defun docstring-ispec (label object kind)
+ "Return a inspector spec if OBJECT has a docstring of of kind KIND."
+ (let ((docstring (documentation object kind)))
+ (cond ((not docstring) nil)
+ ((< (+ (length label) (length docstring))
+ 75)
+ (list label ": " docstring '(:newline)))
+ (t
+ (list label ": " '(:newline) " " docstring '(:newline))))))
+
+(defmethod inspect-for-emacs ((f function) inspector)
+ (declare (ignore inspector))
+ (values "A function."
+ (append
+ (label-value-line "Name" (function-name f))
+ `("Its argument list is: "
+ ,(inspector-princ (arglist f)) (:newline))
+ (docstring-ispec "Documentation" f t)
+ (if (function-lambda-expression f)
+ (label-value-line "Lambda Expression"
+ (function-lambda-expression f))))))
+
+(defun method-specializers-for-inspect (method)
+ "Return a \"pretty\" list of the method's specializers. Normal
+ specializers are replaced by the name of the class, eql
+ specializers are replaced by `(eql ,object)."
+ (mapcar (lambda (spec)
+ (typecase spec
+ (swank-mop:eql-specializer
+ `(eql ,(swank-mop:eql-specializer-object spec)))
+ (t (swank-mop:class-name spec))))
+ (swank-mop:method-specializers method)))
+
+(defun method-for-inspect-value (method)
+ "Returns a \"pretty\" list describing METHOD. The first element
+ of the list is the name of generic-function method is
+ specialiazed on, the second element is the method qualifiers,
+ the rest of the list is the method's specialiazers (as per
+ method-specializers-for-inspect)."
+ (append (list (swank-mop:generic-function-name
+ (swank-mop:method-generic-function method)))
+ (swank-mop:method-qualifiers method)
+ (method-specializers-for-inspect method)))
+
+(defmethod inspect-for-emacs ((object standard-object)
+ (inspector fancy-inspector))
+ (let ((class (class-of object)))
+ (values "An object."
+ `("Class: " (:value ,class) (:newline)
+ ,@(all-slots-for-inspector object inspector)))))
+
+(defvar *gf-method-getter* 'methods-by-applicability
+ "This function is called to get the methods of a generic function.
+The default returns the method sorted by applicability.
+See `methods-by-applicability'.")
+
+(defun specializer< (specializer1 specializer2)
+ "Return true if SPECIALIZER1 is more specific than SPECIALIZER2."
+ (let ((s1 specializer1) (s2 specializer2) )
+ (cond ((typep s1 'swank-mop:eql-specializer)
+ (not (typep s2 'swank-mop:eql-specializer)))
+ (t
+ (flet ((cpl (class)
+ (and (swank-mop:class-finalized-p class)
+ (swank-mop:class-precedence-list class))))
+ (member s2 (cpl s1)))))))
+
+(defun methods-by-applicability (gf)
+ "Return methods ordered by most specific argument types.
+
+`method-specializer<' is used for sorting."
+ ;; FIXME: argument-precedence-order and qualifiers are ignored.
+ (labels ((method< (meth1 meth2)
+ (loop for s1 in (swank-mop:method-specializers meth1)
+ for s2 in (swank-mop:method-specializers meth2)
+ do (cond ((specializer< s2 s1) (return nil))
+ ((specializer< s1 s2) (return t))))))
+ (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<)))
+
+(defun abbrev-doc (doc &optional (maxlen 80))
+ "Return the first sentence of DOC, but not more than MAXLAN characters."
+ (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen)))
+ maxlen
+ (length doc))))
+
+(defgeneric inspect-slot-for-emacs (class object slot)
+ (:method (class object slot)
+ (let ((slot-name (swank-mop:slot-definition-name slot))
+ (boundp (swank-mop:slot-boundp-using-class class object slot)))
+ `(,@(if boundp
+ `((:value ,(swank-mop:slot-value-using-class class object slot)))
+ `("#<unbound>"))
+ " "
+ (:action "[set value]"
+ ,(lambda () (with-simple-restart
+ (abort "Abort setting slot ~S" slot-name)
+ (let ((value-string (eval-in-emacs
+ `(condition-case c
+ (slime-read-object
+ ,(format nil "Set slot ~S to (evaluated) : " slot-name))
+ (quit nil)))))
+ (when (and value-string
+ (not (string= value-string "")))
+ (setf (swank-mop:slot-value-using-class class object slot)
+ (eval (read-from-string value-string))))))))
+ ,@(when boundp
+ `(" " (:action "[make unbound]"
+ ,(lambda () (swank-mop:slot-makunbound-using-class class object slot)))))))))
+
+(defgeneric all-slots-for-inspector (object inspector)
+ (:method ((object standard-object) inspector)
+ (declare (ignore inspector))
+ (append '("--------------------" (:newline)
+ "All Slots:" (:newline))
+ (let* ((class (class-of object))
+ (direct-slots (swank-mop:class-direct-slots class))
+ (effective-slots (sort (copy-seq (swank-mop:class-slots class))
+ #'string< :key #'swank-mop:slot-definition-name))
+ (slot-presentations (loop for effective-slot :in effective-slots
+ collect (inspect-slot-for-emacs
+ class object effective-slot)))
+ (longest-slot-name-length
+ (loop for slot :in effective-slots
+ maximize (length (symbol-name
+ (swank-mop:slot-definition-name slot))))))
+ (loop
+ for effective-slot :in effective-slots
+ for slot-presentation :in slot-presentations
+ for direct-slot = (find (swank-mop:slot-definition-name effective-slot)
+ direct-slots :key #'swank-mop:slot-definition-name)
+ for slot-name = (inspector-princ
+ (swank-mop:slot-definition-name effective-slot))
+ for padding-length = (- longest-slot-name-length
+ (length (symbol-name
+ (swank-mop:slot-definition-name
+ effective-slot))))
+ collect `(:value ,(if direct-slot
+ (list direct-slot effective-slot)
+ effective-slot)
+ ,slot-name)
+ collect (make-array padding-length
+ :element-type 'character
+ :initial-element #\Space)
+ collect " = "
+ append slot-presentation
+ collect '(:newline))))))
+
+(defmethod inspect-for-emacs ((gf standard-generic-function)
+ (inspector fancy-inspector))
+ (flet ((lv (label value) (label-value-line label value)))
+ (values
+ "A generic function."
+ (append
+ (lv "Name" (swank-mop:generic-function-name gf))
+ (lv "Arguments" (swank-mop:generic-function-lambda-list gf))
+ (docstring-ispec "Documentation" gf t)
+ (lv "Method class" (swank-mop:generic-function-method-class gf))
+ (lv "Method combination"
+ (swank-mop:generic-function-method-combination gf))
+ `("Methods: " (:newline))
+ (loop for method in (funcall *gf-method-getter* gf) append
+ `((:value ,method ,(inspector-princ
+ ;; drop the name of the GF
+ (cdr (method-for-inspect-value method))))
+ " "
+ (:action "[remove method]"
+ ,(let ((m method)) ; LOOP reassigns method
+ (lambda ()
+ (remove-method gf m))))
+ (:newline)))
+ `((:newline))
+ (all-slots-for-inspector gf inspector)))))
+
+(defmethod inspect-for-emacs ((method standard-method)
+ (inspector fancy-inspector))
+ (values "A method."
+ `("Method defined on the generic function "
+ (:value ,(swank-mop:method-generic-function method)
+ ,(inspector-princ
+ (swank-mop:generic-function-name
+ (swank-mop:method-generic-function method))))
+ (:newline)
+ ,@(docstring-ispec "Documentation" method t)
+ "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
+ (:newline)
+ "Specializers: " (:value ,(swank-mop:method-specializers method)
+ ,(inspector-princ (method-specializers-for-inspect method)))
+ (:newline)
+ "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
+ (:newline)
+ "Method function: " (:value ,(swank-mop:method-function method))
+ (:newline)
+ ,@(all-slots-for-inspector method inspector))))
+
+(defmethod inspect-for-emacs ((class standard-class)
+ (inspector fancy-inspector))
+ (values "A class."
+ `("Name: " (:value ,(class-name class))
+ (:newline)
+ "Super classes: "
+ ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
+ (:newline)
+ "Direct Slots: "
+ ,@(common-seperated-spec
+ (swank-mop:class-direct-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot)))))
+ (:newline)
+ "Effective Slots: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (common-seperated-spec
+ (swank-mop:class-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(inspector-princ
+ (swank-mop:slot-definition-name slot)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)
+ ,@(let ((doc (documentation class t)))
+ (when doc
+ `("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
+ "Sub classes: "
+ ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
+ (lambda (sub)
+ `(:value ,sub ,(inspector-princ (class-name sub)))))
+ (:newline)
+ "Precedence List: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (common-seperated-spec (swank-mop:class-precedence-list class)
+ (lambda (class)
+ `(:value ,class ,(inspector-princ (class-name class)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)
+ ,@(when (swank-mop:specializer-direct-methods class)
+ `("It is used as a direct specializer in the following methods:" (:newline)
+ ,@(loop
+ for method in (sort (copy-seq (swank-mop:specializer-direct-methods class))
+ #'string< :key (lambda (x)
+ (symbol-name
+ (let ((name (swank-mop::generic-function-name
+ (swank-mop::method-generic-function x))))
+ (if (symbolp name) name (second name))))))
+ collect " "
+ collect `(:value ,method ,(inspector-princ (method-for-inspect-value method)))
+ collect '(:newline)
+ if (documentation method t)
+ collect " Documentation: " and
+ collect (abbrev-doc (documentation method t)) and
+ collect '(:newline))))
+ "Prototype: " ,(if (swank-mop:class-finalized-p class)
+ `(:value ,(swank-mop:class-prototype class))
+ '"#<N/A (class not finalized)>")
+ (:newline)
+ ,@(all-slots-for-inspector class inspector))))
+
+(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition)
+ (inspector fancy-inspector))
+ (values "A slot."
+ `("Name: " (:value ,(swank-mop:slot-definition-name slot))
+ (:newline)
+ ,@(when (swank-mop:slot-definition-documentation slot)
+ `("Documentation:" (:newline)
+ (:value ,(swank-mop:slot-definition-documentation slot))
+ (:newline)))
+ "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
+ "Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
+ `(:value ,(swank-mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
+ (:newline)
+ ,@(all-slots-for-inspector slot inspector))))
+
+
+;; Wrapper structure over the list of symbols of a package that should
+;; be displayed with their respective classification flags. This is
+;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS.
+;; Used by the Inspector for packages.
+(defstruct (%package-symbols-container (:conc-name %container.)
+ (:constructor %%make-package-symbols-container))
+ title ;; A string; the title of the inspector page in Emacs.
+ description ;; A list of renderable objects; used as description.
+ symbols ;; A list of symbols. Supposed to be sorted alphabetically.
+ grouping-kind ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING.
+ )
+
+(defun %make-package-symbols-container (&key title description symbols)
+ (%%make-package-symbols-container :title title :description description
+ :symbols symbols :grouping-kind :symbol))
+
+(defgeneric make-symbols-listing (grouping-kind symbols))
+
+(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols)
+ "Returns an object renderable by Emacs' inspector side that
+alphabetically lists all the symbols in SYMBOLS together with a
+concise string representation of what each symbol
+represents (cf. CLASSIFY-SYMBOL & Fuzzy Completion.)"
+ (let ((max-length (loop for s in symbols maximizing (length (symbol-name s))))
+ (distance 10)) ; empty distance between name and classification
+ (flet ((string-representations (symbol)
+ (let* ((name (symbol-name symbol))
+ (length (length name))
+ (padding (- max-length length))
+ (classification (classify-symbol symbol)))
+ (values
+ (concatenate 'string
+ name
+ (make-string (+ padding distance) :initial-element #\Space))
+ (symbol-classification->string classification)))))
+ `("" ; 8 is (length "Symbols:")
+ "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:"
+ (:newline)
+ ,(concatenate 'string ; underlining dashes
+ (make-string (+ max-length distance -1) :initial-element #\-)
+ " "
+ (let* ((dummy (classify-symbol (gensym)))
+ (dummy (symbol-classification->string dummy))
+ (classification-length (length dummy)))
+ (make-string classification-length :initial-element #\-)))
+ (:newline)
+ ,@(loop for symbol in symbols appending
+ (multiple-value-bind (symbol-string classification-string)
+ (string-representations symbol)
+ `((:value ,symbol ,symbol-string) ,classification-string
+ (:newline)
+ )))))))
+
+(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols)
+ "For each possible classification (cf. CLASSIFY-SYMBOL), group
+all the symbols in SYMBOLS to all of their respective
+classifications. (If a symbol is, for instance, boundp and a
+generic-function, it'll appear both below the BOUNDP group and
+the GENERIC-FUNCTION group.) As macros and special-operators are
+specified to be FBOUNDP, there is no general FBOUNDP group,
+instead there are the three explicit FUNCTION, MACRO and
+SPECIAL-OPERATOR groups."
+ (let ((table (make-hash-table :test #'eq)))
+ (flet ((maybe-convert-fboundps (classifications)
+ ;; Convert an :FBOUNDP in CLASSIFICATIONS to :FUNCTION if possible.
+ (if (and (member :fboundp classifications)
+ (not (member :macro classifications))
+ (not (member :special-operator classifications)))
+ (substitute :function :fboundp classifications)
+ (remove :fboundp classifications))))
+ (loop for symbol in symbols do
+ (loop for classification in (maybe-convert-fboundps (classify-symbol symbol))
+ ;; SYMBOLS are supposed to be sorted alphabetically;
+ ;; this property is preserved here except for reversing.
+ do (push symbol (gethash classification table)))))
+ (let* ((classifications (loop for k being each hash-key in table collect k))
+ (classifications (sort classifications #'string<)))
+ (loop for classification in classifications
+ for symbols = (gethash classification table)
+ appending`(,(symbol-name classification)
+ (:newline)
+ ,(make-string 64 :initial-element #\-)
+ (:newline)
+ ,@(mapcan #'(lambda (symbol)
+ (list `(:value ,symbol ,(symbol-name symbol)) '(:newline)))
+ (nreverse symbols)) ; restore alphabetic orderness.
+ (:newline)
+ )))))
+
+(defmethod inspect-for-emacs ((%container %package-symbols-container)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (with-struct (%container. title description symbols grouping-kind) %container
+ (values title
+ `(,@description
+ (:newline)
+ " " ,(ecase grouping-kind
+ (:symbol
+ `(:action "[Group by classification]"
+ ,(lambda () (setf grouping-kind :classification))
+ :refreshp t))
+ (:classification
+ `(:action "[Group by symbol]"
+ ,(lambda () (setf grouping-kind :symbol))
+ :refreshp t)))
+ (:newline) (:newline)
+ ,@(make-symbols-listing grouping-kind symbols)))))
+
+
+(defmethod inspect-for-emacs ((package package)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (let ((package-name (package-name package))
+ (package-nicknames (package-nicknames package))
+ (package-use-list (package-use-list package))
+ (package-used-by-list (package-used-by-list package))
+ (shadowed-symbols (package-shadowing-symbols package))
+ (present-symbols '()) (present-symbols-length 0)
+ (internal-symbols '()) (internal-symbols-length 0)
+ (external-symbols '()) (external-symbols-length 0))
+
+ (do-symbols* (sym package)
+ (let ((status (symbol-status sym package)))
+ (when (not (eq status :inherited))
+ (push sym present-symbols) (incf present-symbols-length)
+ (if (eq status :internal)
+ (progn (push sym internal-symbols) (incf internal-symbols-length))
+ (progn (push sym external-symbols) (incf external-symbols-length))))))
+
+ (setf package-nicknames (sort (copy-list package-nicknames) #'string<)
+ package-use-list (sort (copy-list package-use-list) #'string< :key #'package-name)
+ package-used-by-list (sort (copy-list package-used-by-list) #'string< :key #'package-name)
+ shadowed-symbols (sort (copy-list shadowed-symbols) #'string<))
+
+ (setf present-symbols (sort present-symbols #'string<) ; SORT + STRING-LESSP
+ internal-symbols (sort internal-symbols #'string<) ; conses on at least
+ external-symbols (sort external-symbols #'string<)) ; SBCL 0.9.18.
+
+
+ (values
+ "A package."
+ `("" ; dummy to preserve indentation.
+ "Name: " (:value ,package-name) (:newline)
+
+ "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline)
+
+ ,@(when (documentation package t)
+ `("Documentation:" (:newline) ,(documentation package t) (:newline)))
+
+ "Use list: " ,@(common-seperated-spec
+ package-use-list
+ (lambda (package)
+ `(:value ,package ,(package-name package))))
+ (:newline)
+
+ "Used by list: " ,@(common-seperated-spec
+ package-used-by-list
+ (lambda (package)
+ `(:value ,package ,(package-name package))))
+ (:newline)
+
+ ,@ ; ,@(flet ((...)) ...) would break indentation in Emacs.
+ (flet ((display-link (type symbols length &key title description)
+ (if (null symbols)
+ (format nil "0 ~A symbols." type)
+ `(:value ,(%make-package-symbols-container :title title
+ :description description
+ :symbols symbols)
+ ,(format nil "~D ~A symbol~P." length type length)))))
+
+ `(,(display-link "present" present-symbols present-symbols-length
+ :title (format nil "All present symbols of package \"~A\"" package-name)
+ :description
+ '("A symbol is considered present in a package if it's" (:newline)
+ "\"accessible in that package directly, rather than" (:newline)
+ "being inherited from another package.\"" (:newline)
+ "(CLHS glossary entry for `present')" (:newline)))
+
+ (:newline)
+ ,(display-link "external" external-symbols external-symbols-length
+ :title (format nil "All external symbols of package \"~A\"" package-name)
+ :description
+ '("A symbol is considered external of a package if it's" (:newline)
+ "\"part of the `external interface' to the package and" (:newline)
+ "[is] inherited by any other package that uses the" (:newline)
+ "package.\" (CLHS glossary entry of `external')" (:newline)))
+ (:newline)
+ ,(display-link "internal" internal-symbols internal-symbols-length
+ :title (format nil "All internal symbols of package \"~A\"" package-name)
+ :description
+ '("A symbol is considered internal of a package if it's" (:newline)
+ "present and not external---that is if the package is" (:newline)
+ "the home package of the symbol, or if the symbol has" (:newline)
+ "been explicitly imported into the package." (:newline)
+ (:newline)
+ "Notice that inherited symbols will thus not be listed," (:newline)
+ "which deliberately deviates from the CLHS glossary" (:newline)
+ "entry of `internal' because it's assumed to be more" (:newline)
+ "useful this way." (:newline)))
+ (:newline)
+ ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
+ :title (format nil "All shadowed symbols of package \"~A\"" package-name)
+ :description nil)))))))
+
+
+(defmethod inspect-for-emacs ((pathname pathname)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (values (if (wild-pathname-p pathname)
+ "A wild pathname."
+ "A pathname.")
+ (append (label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Host" (pathname-host pathname))
+ ("Device" (pathname-device pathname))
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname)))
+ (unless (or (wild-pathname-p pathname)
+ (not (probe-file pathname)))
+ (label-value-line "Truename" (truename pathname))))))
+
+(defmethod inspect-for-emacs ((pathname logical-pathname)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (values "A logical pathname."
+ (append
+ (label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Physical pathname: " (translate-logical-pathname pathname)))
+ `("Host: "
+ ,(pathname-host pathname)
+ " (" (:value ,(logical-pathname-translations
+ (pathname-host pathname)))
+ "other translations)"
+ (:newline))
+ (label-value-line*
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname))
+ ("Truename" (if (not (wild-pathname-p pathname))
+ (probe-file pathname)))))))
+
+(defmethod inspect-for-emacs ((n number)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (values "A number." `("Value: " ,(princ-to-string n))))
+
+(defun format-iso8601-time (time-value &optional include-timezone-p)
+ "Formats a universal time TIME-VALUE in ISO 8601 format, with
+ the time zone included if INCLUDE-TIMEZONE-P is non-NIL"
+ ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html
+ ;; Thanks, Nikolai Sandved and Thomas Russ!
+ (flet ((format-iso8601-timezone (zone)
+ (if (zerop zone)
+ "Z"
+ (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+ ;; Tricky. Sign of time zone is reversed in ISO 8601
+ ;; relative to Common Lisp convention!
+ (format nil "~:[+~;-~]~2,'0D:~2,'0D"
+ (> zone 0) h (round (* 60 m)))))))
+ (multiple-value-bind (second minute hour day month year dow dst zone)
+ (decode-universal-time time-value)
+ (declare (ignore dow dst))
+ (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
+ year month day hour minute second
+ include-timezone-p (format-iso8601-timezone zone)))))
+
+(defmethod inspect-for-emacs ((i integer)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (values "A number."
+ (append
+ `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
+ i i i i (ignore-errors (coerce i 'float)))
+ (:newline))
+ (when (< -1 i char-code-limit)
+ (label-value-line "Code-char" (code-char i)))
+ (label-value-line "Integer-length" (integer-length i))
+ (ignore-errors
+ (label-value-line "Universal-time" (format-iso8601-time i t))))))
+
+(defmethod inspect-for-emacs ((c complex)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (values "A complex number."
+ (label-value-line*
+ ("Real part" (realpart c))
+ ("Imaginary part" (imagpart c)))))
+
+(defmethod inspect-for-emacs ((r ratio)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (values "A non-integer ratio."
+ (label-value-line*
+ ("Numerator" (numerator r))
+ ("Denominator" (denominator r))
+ ("As float" (float r)))))
+
+(defmethod inspect-for-emacs ((f float)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (values "A floating point number."
+ (cond
+ ((> f most-positive-long-float)
+ (list "Positive infinity."))
+ ((< f most-negative-long-float)
+ (list "Negative infinity."))
+ ((not (= f f))
+ (list "Not a Number."))
+ (t
+ (multiple-value-bind (significand exponent sign) (decode-float f)
+ (append
+ `("Scientific: " ,(format nil "~E" f) (:newline)
+ "Decoded: "
+ (:value ,sign) " * "
+ (:value ,significand) " * "
+ (:value ,(float-radix f)) "^" (:value ,exponent) (:newline))
+ (label-value-line "Digits" (float-digits f))
+ (label-value-line "Precision" (float-precision f))))))))
+
+(defmethod inspect-for-emacs ((stream file-stream)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (multiple-value-bind (title content)
+ (call-next-method)
+ (declare (ignore title))
+ (values "A file stream."
+ (append
+ `("Pathname: "
+ (:value ,(pathname stream))
+ (:newline) " "
+ (:action "[visit file and show current position]"
+ ,(let ((pathname (pathname stream))
+ (position (file-position stream)))
+ (lambda ()
+ (ed-in-emacs `(,pathname :charpos ,position))))
+ :refreshp nil)
+ (:newline))
+ content))))
+
+(defmethod inspect-for-emacs ((condition stream-error)
+ (inspector fancy-inspector))
+ (declare (ignore inspector))
+ (multiple-value-bind (title content)
+ (call-next-method)
+ (let ((stream (stream-error-stream condition)))
+ (if (typep stream 'file-stream)
+ (values "A stream error."
+ (append
+ `("Pathname: "
+ (:value ,(pathname stream))
+ (:newline) " "
+ (:action "[visit file and show current position]"
+ ,(let ((pathname (pathname stream))
+ (position (file-position stream)))
+ (lambda ()
+ (ed-in-emacs `(,pathname :charpos ,position))))
+ :refreshp nil)
+ (:newline))
+ content))
+ (values title content)))))
+
+(defvar *fancy-inpector-undo-list* nil)
+
+(defslimefun fancy-inspector-init ()
+ (let ((i *default-inspector*))
+ (push (lambda () (setq *default-inspector* i))
+ *fancy-inpector-undo-list*))
+ (setq *default-inspector* (make-instance 'fancy-inspector))
+ t)
+
+(defslimefun fancy-inspector-unload ()
+ (loop while *fancy-inpector-undo-list* do
+ (funcall (pop *fancy-inpector-undo-list*))))
+
+(provide :swank-fancy-inspector)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-fuzzy.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-fuzzy.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,625 @@
+;;; swank-fuzzy.lisp --- fuzzy symbol completion
+;;
+;; Authors: Brian Downing <bdowning(a)lavos.net>
+;; Tobias C. Rittweiler <tcr(a)freebits.de>
+;; and others
+;;
+;; License: Public Domain
+;;
+
+
+(in-package :swank)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (swank-require :swank-c-p-c))
+
+;;; For nomenclature of the fuzzy completion section, please read
+;;; through the following docstring.
+
+(defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec)
+"Returns a list of two values:
+
+ An (optionally limited to LIMIT best results) list of fuzzy
+ completions for a symbol designator STRING. The list will be
+ sorted by score, most likely match first.
+
+ A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
+ been exhausted during computation. If that parameter's value is
+ NIL or 0, no time limit is assumed.
+
+The main result is a list of completion objects, where a completion
+object is:
+
+ (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
+
+where a CHUNK is a description of a matched substring:
+
+ (OFFSET SUBSTRING)
+
+and FLAGS is a list of keywords describing properties of the
+symbol (see CLASSIFY-SYMBOL).
+
+E.g., completing \"mvb\" in a package that uses COMMON-LISP would
+return something like:
+
+ ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
+ (:FBOUNDP :MACRO))
+ ...)
+
+If STRING is package qualified the result list will also be
+qualified. If string is non-qualified the result strings are
+also not qualified and are considered relative to
+DEFAULT-PACKAGE-NAME.
+
+Which symbols are candidates for matching depends on the symbol
+designator's format. The cases are as follows:
+ FOO - Symbols accessible in the buffer package.
+ PKG:FOO - Symbols external in package PKG.
+ PKG::FOO - Symbols accessible in package PKG."
+ ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
+ ;; to denote an infinite time limit. Internally, we only use NIL for
+ ;; that purpose, to be able to distinguish between "no time limit
+ ;; alltogether" and "current time limit already exhausted." So we've
+ ;; got to canonicalize its value at first:
+ (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec)))
+ (time-limit (if no-time-limit-p nil time-limit-in-msec)))
+ (multiple-value-bind (completion-set interrupted-p)
+ (fuzzy-completion-set string default-package-name :limit limit
+ :time-limit-in-msec time-limit)
+ ;; We may send this as elisp [] arrays to spare a coerce here,
+ ;; but then the network serialization were slower by handling arrays.
+ ;; Instead we limit the number of completions that is transferred
+ ;; (the limit is set from Emacs.)
+ (list (coerce completion-set 'list) interrupted-p))))
+
+
+;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
+;;; object that will be sent back to Emacs, as described above.
+
+(defstruct (fuzzy-matching (:conc-name fuzzy-matching.)
+ (:predicate fuzzy-matching-p)
+ (:constructor %make-fuzzy-matching))
+ symbol ; The symbol that has been found to match.
+ package-name ; The name of the package where SYMBOL was found in.
+ ; (This is not necessarily the same as the home-package
+ ; of SYMBOL, because the SYMBOL can be internal to
+ ; lots of packages; also think of package nicknames.)
+ score ; The higher the better SYMBOL is a match.
+ package-chunks ; Chunks pertaining to the package identifier of SYMBOL.
+ symbol-chunks) ; Chunks pertaining to SYMBOL's name.
+
+(defun make-fuzzy-matching (symbol package-name score package-chunks symbol-chunks)
+ (declare (inline %make-fuzzy-matching))
+ (%make-fuzzy-matching :symbol symbol :package-name package-name :score score
+ :package-chunks package-chunks
+ :symbol-chunks symbol-chunks))
+
+(defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string)
+ (multiple-value-bind (_ user-package-name __ input-internal-p)
+ (parse-completion-arguments user-input-string nil)
+ (declare (ignore _ __))
+ (with-struct (fuzzy-matching. score symbol package-name package-chunks symbol-chunks)
+ fuzzy-matching
+ (let (symbol-name real-package-name internal-p)
+ (cond (symbol ; symbol fuzzy matching?
+ (setf symbol-name (symbol-name symbol))
+ (setf internal-p input-internal-p)
+ (setf real-package-name (cond ((keywordp symbol) "")
+ ((not user-package-name) nil)
+ (t package-name))))
+ (t ; package fuzzy matching?
+ (setf symbol-name "")
+ (setf real-package-name package-name)
+ ;; If no explicit package name was given by the user
+ ;; (e.g. input was "asdf"), we want to append only
+ ;; one colon ":" to the package names.
+ (setf internal-p (if user-package-name input-internal-p nil))))
+ (values symbol-name
+ real-package-name
+ (if user-package-name internal-p nil)
+ (completion-output-symbol-converter user-input-string)
+ (completion-output-package-converter user-input-string))))))
+
+(defun fuzzy-format-matching (fuzzy-matching user-input-string)
+ "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING."
+ (multiple-value-bind (symbol-name package-name internal-p symbol-converter package-converter)
+ (%fuzzy-extract-matching-info fuzzy-matching user-input-string)
+ (setq symbol-name (and symbol-name (funcall symbol-converter symbol-name)))
+ (setq package-name (and package-name (funcall package-converter package-name)))
+ (let ((result (untokenize-symbol package-name internal-p symbol-name)))
+ ;; We return the length of the possibly added prefix as second value.
+ (values result (search symbol-name result)))))
+
+(defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string)
+ "Converts a result from the fuzzy completion core into
+something that emacs is expecting. Converts symbols to strings,
+fixes case issues, and adds information describing if the symbol
+is :bound, :fbound, a :class, a :macro, a :generic-function,
+a :special-operator, or a :package."
+ (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching
+ (multiple-value-bind (name added-length)
+ (fuzzy-format-matching fuzzy-matching user-input-string)
+ (list name
+ score
+ (append package-chunks
+ (mapcar #'(lambda (chunk)
+ ;; Fix up chunk positions to account for possible
+ ;; added package identifier.
+ (let ((offset (first chunk)) (string (second chunk)))
+ (list (+ added-length offset) string)))
+ symbol-chunks))
+ (classify-symbol symbol)))))
+
+(defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
+ "Returns two values: an array of completion objects, sorted by
+their score, that is how well they are a match for STRING
+according to the fuzzy completion algorithm. If LIMIT is set,
+only the top LIMIT results will be returned. Additionally, a flag
+is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
+exhausted."
+ (check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
+ (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum))))
+ (multiple-value-bind (matchings interrupted-p)
+ (fuzzy-generate-matchings string default-package-name time-limit-in-msec)
+ (when (and limit
+ (> limit 0)
+ (< limit (length matchings)))
+ (if (array-has-fill-pointer-p matchings)
+ (setf (fill-pointer matchings) limit)
+ (setf matchings (make-array limit :displaced-to matchings))))
+ (map-into matchings #'(lambda (m)
+ (fuzzy-convert-matching-for-emacs m string))
+ matchings)
+ (values matchings interrupted-p)))
+
+
+(defun fuzzy-generate-matchings (string default-package-name time-limit-in-msec)
+ "Does all the hard work for FUZZY-COMPLETION-SET. If
+TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
+ (multiple-value-bind (parsed-symbol-name parsed-package-name package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (flet ((fix-up (matchings parent-package-matching)
+ ;; The components of each matching in MATCHINGS have been computed
+ ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
+ (let* ((p parent-package-matching)
+ (p.name (fuzzy-matching.package-name p))
+ (p.score (fuzzy-matching.score p))
+ (p.chunks (fuzzy-matching.package-chunks p)))
+ (map-into matchings
+ #'(lambda (m)
+ (let ((m.score (fuzzy-matching.score m)))
+ (setf (fuzzy-matching.package-name m) p.name)
+ (setf (fuzzy-matching.package-chunks m) p.chunks)
+ (setf (fuzzy-matching.score m)
+ (if (equal parsed-symbol-name "")
+ ;; (Make package matchings be sorted before all the
+ ;; relative symbol matchings while preserving over
+ ;; all orderness.)
+ (/ p.score 100)
+ (+ p.score m.score)))
+ m))
+ matchings)))
+ (find-symbols (designator package time-limit &optional filter)
+ (fuzzy-find-matching-symbols designator package
+ :time-limit-in-msec time-limit
+ :external-only (not internal-p)
+ :filter (or filter #'identity)))
+ (find-packages (designator time-limit)
+ (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit)))
+ (let ((time-limit time-limit-in-msec) (symbols) (packages) (results))
+ (cond ((not parsed-package-name) ; E.g. STRING = "asd"
+ ;; We don't know if user is searching for a package or a symbol
+ ;; within his current package. So we try to find either.
+ (setf (values packages time-limit) (find-packages parsed-symbol-name time-limit))
+ (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit)))
+ ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
+ (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit)))
+ (t ; E.g. STRING = "asd:" or "asd:foo"
+ ;; Find fuzzy matchings of the denoted package identifier part.
+ ;; After that, find matchings for the denoted symbol identifier
+ ;; relative to all the packages found.
+ (multiple-value-bind (found-packages rest-time-limit)
+ (find-packages parsed-package-name time-limit-in-msec)
+ ;; We want to traverse the found packages in the order of their score,
+ ;; since those with higher score presumably represent better choices.
+ ;; (This is important because some packages may never be looked at if
+ ;; time limit exhausts during traversal.)
+ (setf found-packages (sort found-packages #'fuzzy-matching-greaterp))
+ (loop
+ for package-matching across found-packages
+ for package = (find-package (fuzzy-matching.package-name package-matching))
+ while (or (not time-limit) (> rest-time-limit 0)) do
+ (multiple-value-bind (matchings remaining-time)
+ ;; The duplication filter removes all those symbols which are
+ ;; present in more than one package match. Specifically if such a
+ ;; package match represents the home package of the symbol, it's
+ ;; the one kept because this one is deemed to be the best match.
+ (find-symbols parsed-symbol-name package rest-time-limit
+ (%make-duplicate-symbols-filter
+ (remove package-matching found-packages)))
+ (setf matchings (fix-up matchings package-matching))
+ (setf symbols (concatenate 'vector symbols matchings))
+ (setf rest-time-limit remaining-time)
+ (let ((guessed-sort-duration (%guess-sort-duration (length symbols))))
+ (when (<= rest-time-limit guessed-sort-duration)
+ (decf rest-time-limit guessed-sort-duration)
+ (loop-finish))))
+ finally
+ (setf time-limit rest-time-limit)
+ (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:"
+ (setf packages found-packages))))))
+ ;; Sort by score; thing with equal score, sort alphabetically.
+ ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all possible
+ ;; completions are to be returned.)
+ (setf results (concatenate 'vector symbols packages))
+ (setf results (sort results #'fuzzy-matching-greaterp))
+ (values results (and time-limit (<= time-limit 0)))))))
+
+(defun %guess-sort-duration (length)
+ ;; These numbers are pretty much arbitrary, except that they're
+ ;; vaguely correct on my machine with SBCL. Yes, this is an ugly
+ ;; kludge, but it's better than before (where this didn't exist at
+ ;; all, which essentially meant, that this was taken to be 0.)
+ (if (zerop length)
+ 0
+ (let ((comparasions (* 3.8 (* length (log length 2)))))
+ (* 1000 (* comparasions (expt 10 -7)))))) ; msecs
+
+(defun %make-duplicate-symbols-filter (fuzzy-package-matchings)
+ ;; Returns a filter function that takes a symbol, and which returns T
+ ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents
+ ;; the home-package of the symbol passed.
+ (let ((packages (mapcar #'(lambda (m)
+ (find-package (fuzzy-matching.package-name m)))
+ (coerce fuzzy-package-matchings 'list))))
+ #'(lambda (symbol)
+ (not (member (symbol-package symbol) packages)))))
+
+(defun fuzzy-matching-greaterp (m1 m2)
+ "Returns T if fuzzy-matching M1 should be sorted before M2.
+Basically just the scores of the two matchings are compared, and
+the match with higher score wins. For the case that the score is
+equal, the one which comes alphabetically first wins."
+ (declare (type fuzzy-matching m1 m2))
+ (let ((score1 (fuzzy-matching.score m1))
+ (score2 (fuzzy-matching.score m2)))
+ (cond ((> score1 score2) t)
+ ((< score1 score2) nil) ; total order
+ (t
+ (let ((name1 (symbol-name (fuzzy-matching.symbol m1)))
+ (name2 (symbol-name (fuzzy-matching.symbol m2))))
+ (string< name1 name2))))))
+
+(declaim (ftype (function () (integer 0)) get-real-time-msecs))
+(defun get-real-time-in-msecs ()
+ (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
+ (values (floor (get-internal-real-time) units-per-msec)))) ; return just one value!
+
+(defun fuzzy-find-matching-symbols
+ (string package &key (filter #'identity) external-only time-limit-in-msec)
+ "Returns two values: a vector of fuzzy matchings for matching
+symbols in PACKAGE, using the fuzzy completion algorithm, and the
+remaining time limit.
+
+Only those symbols are considered of which FILTER does return T.
+
+If EXTERNAL-ONLY is true, only external symbols are considered. A
+TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
+negative, perform a NOP."
+ (let ((time-limit-p (and time-limit-in-msec t))
+ (time-limit (or time-limit-in-msec 0))
+ (rtime-at-start (get-real-time-in-msecs))
+ (package-name (package-name package))
+ (count 0))
+ (declare (type boolean time-limit-p))
+ (declare (type integer time-limit rtime-at-start))
+ (declare (type (integer 0 #.(1- most-positive-fixnum)) count))
+
+ (flet ((recompute-remaining-time (old-remaining-time)
+ (cond ((not time-limit-p)
+ (values nil nil)) ; propagate NIL back as infinite time limit.
+ ((> count 0) ; ease up on getting internal time like crazy.
+ (setf count (mod (1+ count) 128))
+ (values nil old-remaining-time))
+ (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))
+ (remaining (- time-limit elapsed-time)))
+ (values (<= remaining 0) remaining)))))
+ (perform-fuzzy-match (string symbol-name)
+ (let* ((converter (completion-output-symbol-converter string))
+ (converted-symbol-name (funcall converter symbol-name)))
+ (compute-highest-scoring-completion string converted-symbol-name))))
+ (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
+ (rest-time-limit time-limit))
+ (block loop
+ (do-symbols* (symbol package)
+ (multiple-value-bind (exhausted? remaining-time)
+ (recompute-remaining-time rest-time-limit)
+ (setf rest-time-limit remaining-time)
+ (cond (exhausted? (return-from loop))
+ ((or (not external-only) (symbol-external-p symbol package))
+ (when (funcall filter symbol)
+ (if (string= "" string) ; "" matches always
+ (vector-push-extend (make-fuzzy-matching symbol package-name
+ 0.0 '() '())
+ completions)
+ (multiple-value-bind (match-result score)
+ (perform-fuzzy-match string (symbol-name symbol))
+ (when match-result
+ (vector-push-extend
+ (make-fuzzy-matching symbol package-name score
+ '() match-result)
+ completions))))))))))
+ (values completions rest-time-limit)))))
+
+
+(defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
+ "Returns a vector of fuzzy matchings for each package that is
+similiar to NAME, and the remaining time limit.
+Cf. FUZZY-FIND-MATCHING-SYMBOLS."
+ (let ((time-limit-p (and time-limit-in-msec t))
+ (time-limit (or time-limit-in-msec 0))
+ (rtime-at-start (get-real-time-in-msecs))
+ (converter (completion-output-package-converter name))
+ (completions (make-array 32 :adjustable t :fill-pointer 0)))
+ (declare (type boolean time-limit-p))
+ (declare (type integer time-limit rtime-at-start))
+ (declare (type function converter))
+ (if (and time-limit-p (<= time-limit 0))
+ (values #() time-limit)
+ (loop for package in (list-all-packages) do
+ ;; Find best-matching package-nickname:
+ (loop with max-pkg-name = ""
+ with max-result = nil
+ with max-score = 0
+ for package-name in (package-names package)
+ for converted-name = (funcall converter package-name)
+ do
+ (multiple-value-bind (result score)
+ (compute-highest-scoring-completion name converted-name)
+ (when (and result (> score max-score))
+ (setf max-pkg-name package-name)
+ (setf max-result result)
+ (setf max-score score)))
+ finally
+ (when max-result
+ (vector-push-extend (make-fuzzy-matching nil max-pkg-name
+ max-score max-result '())
+ completions)))
+ finally
+ (return
+ (values completions
+ (and time-limit-p
+ (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)))
+ (- time-limit elapsed-time)))))))))
+
+
+(defslimefun fuzzy-completion-selected (original-string completion)
+ "This function is called by Slime when a fuzzy completion is
+selected by the user. It is for future expansion to make
+testing, say, a machine learning algorithm for completion scoring
+easier.
+
+ORIGINAL-STRING is the string the user completed from, and
+COMPLETION is the completion object (see docstring for
+SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
+user selected."
+ (declare (ignore original-string completion))
+ nil)
+
+
+;;;;; Fuzzy completion core
+
+(defparameter *fuzzy-recursion-soft-limit* 30
+ "This is a soft limit for recursion in
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
+completing a string such as \"ZZZZZZ\" with a symbol named
+\"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
+find all the ways it can match.
+
+Most natural language searches and symbols do not have this
+problem -- this is only here as a safeguard.")
+(declaim (fixnum *fuzzy-recursion-soft-limit*))
+
+(defun compute-highest-scoring-completion (short full)
+ "Finds the highest scoring way to complete the abbreviation
+SHORT onto the string FULL, using CHAR= as a equality function for
+letters. Returns two values: The first being the completion
+chunks of the highest scorer, and the second being the score."
+ (let* ((scored-results
+ (mapcar #'(lambda (result)
+ (cons (score-completion result short full) result))
+ (compute-most-completions short full)))
+ (winner (first (sort scored-results #'> :key #'first))))
+ (values (rest winner) (first winner))))
+
+(defun compute-most-completions (short full)
+ "Finds most possible ways to complete FULL with the letters in SHORT.
+Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
+a list of (&rest CHUNKS), where each CHUNKS is a description of
+how a completion matches."
+ (let ((*all-chunks* nil))
+ (declare (special *all-chunks*))
+ (recursively-compute-most-completions short full 0 0 nil nil nil t)
+ *all-chunks*))
+
+(defun recursively-compute-most-completions
+ (short full
+ short-index initial-full-index
+ chunks current-chunk current-chunk-pos
+ recurse-p)
+ "Recursively (if RECURSE-P is true) find /most/ possible ways
+to fuzzily map the letters in SHORT onto FULL, using CHAR= to
+determine if two letters match.
+
+A chunk is a list of elements that have matched consecutively.
+When consecutive matches stop, it is coerced into a string,
+paired with the starting position of the chunk, and pushed onto
+CHUNKS.
+
+Whenever a letter matches, if RECURSE-P is true,
+RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
+one index ahead, to find other possibly higher scoring
+possibilities. If there are less than
+*FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
+this call will also recurse.
+
+Once a word has been completely matched, the chunks are pushed
+onto the special variable *ALL-CHUNKS* and the function returns."
+ (declare ;(optimize speed)
+ (fixnum short-index initial-full-index)
+ (simple-string short full)
+ (special *all-chunks*))
+ (flet ((short-cur ()
+ "Returns the next letter from the abbreviation, or NIL
+ if all have been used."
+ (if (= short-index (length short))
+ nil
+ (aref short short-index)))
+ (add-to-chunk (char pos)
+ "Adds the CHAR at POS in FULL to the current chunk,
+ marking the start position if it is empty."
+ (unless current-chunk
+ (setf current-chunk-pos pos))
+ (push char current-chunk))
+ (collect-chunk ()
+ "Collects the current chunk to CHUNKS and prepares for
+ a new chunk."
+ (when current-chunk
+ (push (list current-chunk-pos
+ (coerce (reverse current-chunk) 'string)) chunks)
+ (setf current-chunk nil
+ current-chunk-pos nil))))
+ ;; If there's an outstanding chunk coming in collect it. Since
+ ;; we're recursively called on skipping an input character, the
+ ;; chunk can't possibly continue on.
+ (when current-chunk (collect-chunk))
+ (do ((pos initial-full-index (1+ pos)))
+ ((= pos (length full)))
+ (let ((cur-char (aref full pos)))
+ (if (and (short-cur)
+ (char= cur-char (short-cur)))
+ (progn
+ (when recurse-p
+ ;; Try other possibilities, limiting insanely deep
+ ;; recursion somewhat.
+ (recursively-compute-most-completions
+ short full short-index (1+ pos)
+ chunks current-chunk current-chunk-pos
+ (not (> (length *all-chunks*)
+ *fuzzy-recursion-soft-limit*))))
+ (incf short-index)
+ (add-to-chunk cur-char pos))
+ (collect-chunk))))
+ (collect-chunk)
+ ;; If we've exhausted the short characters we have a match.
+ (if (short-cur)
+ nil
+ (let ((rev-chunks (reverse chunks)))
+ (push rev-chunks *all-chunks*)
+ rev-chunks))))
+
+
+;;;;; Fuzzy completion scoring
+
+(defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"
+ "Letters that are likely to be at the beginning of a symbol.
+Letters found after one of these prefixes will be scored as if
+they were at the beginning of ths symbol.")
+(defparameter *fuzzy-completion-symbol-suffixes* "*+->"
+ "Letters that are likely to be at the end of a symbol.
+Letters found before one of these suffixes will be scored as if
+they were at the end of the symbol.")
+(defparameter *fuzzy-completion-word-separators* "-/."
+ "Letters that separate different words in symbols. Letters
+after one of these symbols will be scores more highly than other
+letters.")
+
+(defun score-completion (completion short full)
+ "Scores the completion chunks COMPLETION as a completion from
+the abbreviation SHORT to the full string FULL. COMPLETION is a
+list like:
+ ((0 \"mul\") (9 \"v\") (15 \"b\"))
+Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
+would indicate that it completed as such (completed letters
+capitalized):
+ MULtiple-Value-Bind
+
+Letters are given scores based on their position in the string.
+Letters at the beginning of a string or after a prefix letter at
+the beginning of a string are scored highest. Letters after a
+word separator such as #\- are scored next highest. Letters at
+the end of a string or before a suffix letter at the end of a
+string are scored medium, and letters anywhere else are scored
+low.
+
+If a letter is directly after another matched letter, and its
+intrinsic value in that position is less than a percentage of the
+previous letter's value, it will use that percentage instead.
+
+Finally, a small scaling factor is applied to favor shorter
+matches, all other things being equal."
+ (labels ((at-beginning-p (pos)
+ (= pos 0))
+ (after-prefix-p (pos)
+ (and (= pos 1)
+ (find (aref full 0) *fuzzy-completion-symbol-prefixes*)))
+ (word-separator-p (pos)
+ (find (aref full pos) *fuzzy-completion-word-separators*))
+ (after-word-separator-p (pos)
+ (find (aref full (1- pos)) *fuzzy-completion-word-separators*))
+ (at-end-p (pos)
+ (= pos (1- (length full))))
+ (before-suffix-p (pos)
+ (and (= pos (- (length full) 2))
+ (find (aref full (1- (length full)))
+ *fuzzy-completion-symbol-suffixes*)))
+ (score-or-percentage-of-previous (base-score pos chunk-pos)
+ (if (zerop chunk-pos)
+ base-score
+ (max base-score
+ (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85)
+ (expt 1.2 chunk-pos)))))
+ (score-char (pos chunk-pos)
+ (score-or-percentage-of-previous
+ (cond ((at-beginning-p pos) 10)
+ ((after-prefix-p pos) 10)
+ ((word-separator-p pos) 1)
+ ((after-word-separator-p pos) 8)
+ ((at-end-p pos) 6)
+ ((before-suffix-p pos) 6)
+ (t 1))
+ pos chunk-pos))
+ (score-chunk (chunk)
+ (loop for chunk-pos below (length (second chunk))
+ for pos from (first chunk)
+ summing (score-char pos chunk-pos))))
+ (let* ((chunk-scores (mapcar #'score-chunk completion))
+ (length-score (/ 10.0 (1+ (- (length full) (length short))))))
+ (values
+ (+ (reduce #'+ chunk-scores) length-score)
+ (list (mapcar #'list chunk-scores completion) length-score)))))
+
+(defun highlight-completion (completion full)
+ "Given a chunk definition COMPLETION and the string FULL,
+HIGHLIGHT-COMPLETION will create a string that demonstrates where
+the completion matched in the string. Matches will be
+capitalized, while the rest of the string will be lower-case."
+ (let ((highlit (nstring-downcase (copy-seq full))))
+ (dolist (chunk completion)
+ (setf highlit (nstring-upcase highlit
+ :start (first chunk)
+ :end (+ (first chunk)
+ (length (second chunk))))))
+ highlit))
+
+(defun format-fuzzy-completion-set (winners)
+ "Given a list of completion objects such as on returned by
+FUZZY-COMPLETION-SET, format the list into user-readable output
+for interactive debugging purpose."
+ (let ((max-len
+ (loop for winner in winners maximizing (length (first winner)))))
+ (loop for (sym score result) in winners do
+ (format t "~&~VA score ~8,2F ~A"
+ max-len (highlight-completion result sym) score result))))
+
+(provide :swank-fuzzy)
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-listener-hooks.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-listener-hooks.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,82 @@
+;;; swank-listener-hooks.lisp --- listener with special hooks
+;;
+;; Author: Alan Ruttenberg <alanr-l(a)mumble.net>
+
+;; I guess that only Alan Ruttenberg knows how to use this code. It
+;; was in swank.lisp for a long time, so here it is. -- Helmut Eller
+
+(defvar *slime-repl-advance-history* nil
+ "In the dynamic scope of a single form typed at the repl, is set to nil to
+ prevent the repl from advancing the history - * ** *** etc.")
+
+(defvar *slime-repl-suppress-output* nil
+ "In the dynamic scope of a single form typed at the repl, is set to nil to
+ prevent the repl from printing the result of the evalation.")
+
+(defvar *slime-repl-eval-hook-pass* (gensym "PASS")
+ "Token to indicate that a repl hook declines to evaluate the form")
+
+(defvar *slime-repl-eval-hooks* nil
+ "A list of functions. When the repl is about to eval a form, first try running each of
+ these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass*
+ is considered a replacement for calling eval. If there are no hooks, or all
+ pass, then eval is used.")
+
+(defslimefun repl-eval-hook-pass ()
+ "call when repl hook declines to evaluate the form"
+ (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*))
+
+(defslimefun repl-suppress-output ()
+ "In the dynamic scope of a single form typed at the repl, call to
+ prevent the repl from printing the result of the evalation."
+ (setq *slime-repl-suppress-output* t))
+
+(defslimefun repl-suppress-advance-history ()
+ "In the dynamic scope of a single form typed at the repl, call to
+ prevent the repl from advancing the history - * ** *** etc."
+ (setq *slime-repl-advance-history* nil))
+
+(defun %eval-region (string)
+ (with-input-from-string (stream string)
+ (let (- values)
+ (loop
+ (let ((form (read stream nil stream)))
+ (when (eq form stream)
+ (fresh-line)
+ (finish-output)
+ (return (values values -)))
+ (setq - form)
+ (if *slime-repl-eval-hooks*
+ (setq values (run-repl-eval-hooks form))
+ (setq values (multiple-value-list (eval form))))
+ (finish-output))))))
+
+(defun run-repl-eval-hooks (form)
+ (loop for hook in *slime-repl-eval-hooks*
+ for res = (catch *slime-repl-eval-hook-pass*
+ (multiple-value-list (funcall hook form)))
+ until (not (eq res *slime-repl-eval-hook-pass*))
+ finally (return
+ (if (eq res *slime-repl-eval-hook-pass*)
+ (multiple-value-list (eval form))
+ res))))
+
+(defun %listener-eval (string)
+ (clear-user-input)
+ (with-buffer-syntax ()
+ (track-package
+ (lambda ()
+ (let ((*slime-repl-suppress-output* :unset)
+ (*slime-repl-advance-history* :unset))
+ (multiple-value-bind (values last-form) (%eval-region string)
+ (unless (or (and (eq values nil) (eq last-form nil))
+ (eq *slime-repl-advance-history* nil))
+ (setq *** ** ** * * (car values)
+ /// // // / / values))
+ (setq +++ ++ ++ + + last-form)
+ (unless (eq *slime-repl-suppress-output* t)
+ (funcall *send-repl-results-function* values))))))))
+
+(setq *listener-eval-function* '%listener-eval)
+
+(provide :swank-listener-hooks)
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-presentation-streams.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-presentation-streams.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,319 @@
+;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities
+;;; to portions of output
+;;;
+;;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net>
+;;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;;; Helmut Eller <heller(a)common-lisp.net>
+;;;
+;;; License: This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+(in-package :swank)
+
+(swank-require :swank-presentations)
+
+;; This file contains a mechanism for printing to the slime repl so
+;; that the printed result remembers what object it is associated
+;; with. This extends the recording of REPL results.
+;;
+;; There are two methods:
+;;
+;; 1. Depends on the ilisp bridge code being installed and ready to
+;; intercept messages in the printed stream. We encode the
+;; information with a message saying that we are starting to print
+;; an object corresponding to a given id and another when we are
+;; done. The process filter notices these and adds the necessary
+;; text properties to the output.
+;;
+;; 2. Use separate protocol messages :presentation-start and
+;; :presentation-end for sending presentations.
+;;
+;; We only do this if we know we are printing to a slime stream,
+;; checked with the method slime-stream-p. Initially this checks for
+;; the knows slime streams looking at *connections*. In cmucl, sbcl, and
+;; openmcl it also checks if it is a pretty-printing stream which
+;; ultimately prints to a slime stream.
+;;
+;; Method 1 seems to be faster, but the printed escape sequences can
+;; disturb the column counting, and thus the layout in pretty-printing.
+;; We use method 1 when a dedicated output stream is used.
+;;
+;; Method 2 is cleaner and works with pretty printing if the pretty
+;; printers support "annotations". We use method 2 when no dedicated
+;; output stream is used.
+
+;; Control
+(defvar *enable-presenting-readable-objects* t
+ "set this to enable automatically printing presentations for some
+subset of readable objects, such as pathnames." )
+
+;; doing it
+
+(defmacro presenting-object (object stream &body body)
+ "What you use in your code. Wrap this around some printing and that text will
+be sensitive and remember what object it is in the repl"
+ `(presenting-object-1 ,object ,stream #'(lambda () ,@body)))
+
+(defmacro presenting-object-if (predicate object stream &body body)
+ "What you use in your code. Wrap this around some printing and that text will
+be sensitive and remember what object it is in the repl if predicate is true"
+ (let ((continue (gensym)))
+ `(let ((,continue #'(lambda () ,@body)))
+ (if ,predicate
+ (presenting-object-1 ,object ,stream ,continue)
+ (funcall ,continue)))))
+
+;;; Get pretty printer patches for SBCL at load (not compile) time.
+#+sbcl
+(eval-when (:load-toplevel)
+ (handler-bind ((simple-error
+ (lambda (c)
+ (declare (ignore c))
+ (let ((clobber-it (find-restart 'sb-kernel::clobber-it)))
+ (when clobber-it (invoke-restart clobber-it))))))
+ (sb-ext:without-package-locks
+ (swank-backend::with-debootstrapping
+ (load (make-pathname
+ :name "sbcl-pprint-patch"
+ :type "lisp"
+ :directory (pathname-directory swank-loader:*source-directory*)))))))
+
+(let ((last-stream nil)
+ (last-answer nil))
+ (defun slime-stream-p (stream)
+ "Check if stream is one of the slime streams, since if it isn't we
+don't want to present anything.
+Two special return values:
+:DEDICATED -- Output ends up on a dedicated output stream
+:REPL-RESULT -- Output ends up on the :repl-results target.
+"
+ (if (eq last-stream stream)
+ last-answer
+ (progn
+ (setq last-stream stream)
+ (if (eq stream t)
+ (setq stream *standard-output*))
+ (setq last-answer
+ (or #+openmcl
+ (and (typep stream 'ccl::xp-stream)
+ ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure)))
+ (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1)))
+ #+cmu
+ (or (and (typep stream 'lisp::indenting-stream)
+ (slime-stream-p (lisp::indenting-stream-stream stream)))
+ (and (typep stream 'pretty-print::pretty-stream)
+ (fboundp 'pretty-print::enqueue-annotation)
+ (let ((slime-stream-p
+ (slime-stream-p (pretty-print::pretty-stream-target stream))))
+ (and ;; Printing through CMUCL pretty
+ ;; streams is only cleanly
+ ;; possible if we are using the
+ ;; bridge-less protocol with
+ ;; annotations, because the bridge
+ ;; escape sequences disturb the
+ ;; pretty printer layout.
+ (not (eql slime-stream-p :dedicated-output))
+ ;; If OK, return the return value
+ ;; we got from slime-stream-p on
+ ;; the target stream (could be
+ ;; :repl-result):
+ slime-stream-p))))
+ #+sbcl
+ (let ()
+ (declare (notinline sb-pretty::pretty-stream-target))
+ (or (and (typep stream 'sb-impl::indenting-stream)
+ (slime-stream-p (sb-impl::indenting-stream-stream stream)))
+ (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))
+ (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)
+ (not *use-dedicated-output-stream*)
+ (slime-stream-p (sb-pretty::pretty-stream-target stream)))))
+ #+allegro
+ (and (typep stream 'excl:xp-simple-stream)
+ (slime-stream-p (excl::stream-output-handle stream)))
+ (loop for connection in *connections*
+ thereis (or (and (eq stream (connection.dedicated-output connection))
+ :dedicated)
+ (eq stream (connection.socket-io connection))
+ (eq stream (connection.user-output connection))
+ (eq stream (connection.user-io connection))
+ (and (eq stream (connection.repl-results connection))
+ :repl-result)))))))))
+
+(defun can-present-readable-objects (&optional stream)
+ (declare (ignore stream))
+ *enable-presenting-readable-objects*)
+
+;; If we are printing to an XP (pretty printing) stream, printing the
+;; escape sequences directly would mess up the layout because column
+;; counting is disturbed. Use "annotations" instead.
+#+allegro
+(defun write-annotation (stream function arg)
+ (if (typep stream 'excl:xp-simple-stream)
+ (excl::schedule-annotation stream function arg)
+ (funcall function arg stream nil)))
+#+cmu
+(defun write-annotation (stream function arg)
+ (if (and (typep stream 'pp:pretty-stream)
+ (fboundp 'pp::enqueue-annotation))
+ (pp::enqueue-annotation stream function arg)
+ (funcall function arg stream nil)))
+#+sbcl
+(defun write-annotation (stream function arg)
+ (let ((enqueue-annotation
+ (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty)))
+ (if (and enqueue-annotation
+ (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)))
+ (funcall enqueue-annotation stream function arg)
+ (funcall function arg stream nil))))
+#-(or allegro cmu sbcl)
+(defun write-annotation (stream function arg)
+ (funcall function arg stream nil))
+
+(defstruct presentation-record
+ (id)
+ (printed-p)
+ (target))
+
+(defun presentation-start (record stream truncatep)
+ (unless truncatep
+ ;; Don't start new presentations when nothing is going to be
+ ;; printed due to *print-lines*.
+ (let ((pid (presentation-record-id record))
+ (target (presentation-record-target record)))
+ (case target
+ (:dedicated
+ ;; Use bridge protocol
+ (write-string "<" stream)
+ (prin1 pid stream)
+ (write-string " " stream))
+ (t
+ (finish-output stream)
+ (send-to-emacs `(:presentation-start ,pid ,target)))))
+ (setf (presentation-record-printed-p record) t)))
+
+(defun presentation-end (record stream truncatep)
+ (declare (ignore truncatep))
+ ;; Always end old presentations that were started.
+ (when (presentation-record-printed-p record)
+ (let ((pid (presentation-record-id record))
+ (target (presentation-record-target record)))
+ (case target
+ (:dedicated
+ ;; Use bridge protocol
+ (write-string ">" stream)
+ (prin1 pid stream)
+ (write-string " " stream))
+ (t
+ (finish-output stream)
+ (send-to-emacs `(:presentation-end ,pid ,target)))))))
+
+(defun presenting-object-1 (object stream continue)
+ "Uses the bridge mechanism with two messages >id and <id. The first one
+says that I am starting to print an object with this id. The second says I am finished"
+ (let ((slime-stream-p
+ (and *record-repl-results* (slime-stream-p stream))))
+ (if slime-stream-p
+ (let* ((pid (swank::save-presented-object object))
+ (record (make-presentation-record :id pid :printed-p nil
+ :target (if (eq slime-stream-p :repl-result)
+ :repl-result
+ nil))))
+ (write-annotation stream #'presentation-start record)
+ (multiple-value-prog1
+ (funcall continue)
+ (write-annotation stream #'presentation-end record)))
+ (funcall continue))))
+
+(defun present-repl-results-via-presentation-streams (values)
+ ;; Override a function in swank.lisp, so that
+ ;; nested presentations work in the REPL result.
+ (let ((repl-results (connection.repl-results *emacs-connection*)))
+ (flet ((send (value)
+ (presenting-object value repl-results
+ (prin1 value repl-results))
+ (terpri repl-results)))
+ (if (null values)
+ (progn
+ (princ "; No value" repl-results)
+ (terpri repl-results))
+ (mapc #'send values)))
+ (finish-output repl-results)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class)
+#+openmcl
+(in-package :ccl)
+#+openmcl
+(let ((*warn-if-redefine-kernel* nil)
+ (*warn-if-redefine* nil))
+ (defun %print-unreadable-object (object stream type id thunk)
+ (cond ((null stream) (setq stream *standard-output*))
+ ((eq stream t) (setq stream *terminal-io*)))
+ (swank::presenting-object object stream
+ (write-unreadable-start object stream)
+ (when type
+ (princ (type-of object) stream)
+ (stream-write-char stream #\space))
+ (when thunk
+ (funcall thunk))
+ (if id
+ (%write-address object stream #\>)
+ (pp-end-block stream ">"))
+ nil))
+ (defmethod print-object :around ((pathname pathname) stream)
+ (swank::presenting-object-if
+ (swank::can-present-readable-objects stream)
+ pathname stream (call-next-method))))
+
+#+openmcl
+(ccl::def-load-pointers clear-presentations ()
+ (swank::clear-presentation-tables))
+
+(in-package :swank)
+
+#+cmu
+(progn
+ (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body)
+ (presenting-object object stream
+ (fwrappers:call-next-function)))
+
+ (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth)
+ (presenting-object-if (can-present-readable-objects stream) pathname stream
+ (fwrappers:call-next-function)))
+
+ (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper)
+ (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper)
+ )
+
+#+sbcl
+(progn
+ (defvar *saved-%print-unreadable-object*
+ (fdefinition 'sb-impl::%print-unreadable-object))
+ (sb-ext:without-package-locks
+ (setf (fdefinition 'sb-impl::%print-unreadable-object)
+ (lambda (object stream type identity body)
+ (presenting-object object stream
+ (funcall *saved-%print-unreadable-object*
+ object stream type identity body))))
+ (defmethod print-object :around ((object pathname) stream)
+ (presenting-object object stream
+ (call-next-method)))))
+
+#+allegro
+(progn
+ (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation)
+ (swank::presenting-object object stream (excl:call-next-fwrapper)))
+ (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth)
+ (presenting-object-if (can-present-readable-objects stream) pathname stream
+ (excl:call-next-fwrapper)))
+ (excl:fwrap 'excl::print-unreadable-object-1
+ 'print-unreadable-present 'presenting-unreadable-wrapper)
+ (excl:fwrap 'excl::pathname-printer
+ 'print-pathname-present 'presenting-pathname-wrapper))
+
+;; Hook into SWANK.
+
+(setq *send-repl-results-function* 'present-repl-results-via-presentation-streams)
+
+(provide :swank-presentation-streams)
Added: branches/bos/thirdparty/emacs/slime/contrib/swank-presentations.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/contrib/swank-presentations.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,235 @@
+;;; swank-presentations.lisp --- imitate LispM's presentations
+;;
+;; Authors: Alan Ruttenberg <alanr-l(a)mumble.net>
+;; Luke Gorrie <luke(a)synap.se>
+;; Helmut Eller <heller(a)common-lisp.net>
+;; Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de>
+;;
+;; License: This code has been placed in the Public Domain. All warranties
+;; are disclaimed.
+;;
+
+(in-package :swank)
+
+;;;; Recording and accessing results of computations
+
+(defvar *record-repl-results* t
+ "Non-nil means that REPL results are saved for later lookup.")
+
+(defvar *object-to-presentation-id*
+ (make-weak-key-hash-table :test 'eq)
+ "Store the mapping of objects to numeric identifiers")
+
+(defvar *presentation-id-to-object*
+ (make-weak-value-hash-table :test 'eql)
+ "Store the mapping of numeric identifiers to objects")
+
+(defun clear-presentation-tables ()
+ (clrhash *object-to-presentation-id*)
+ (clrhash *presentation-id-to-object*))
+
+(defvar *presentation-counter* 0 "identifier counter")
+
+(defvar *nil-surrogate* (make-symbol "nil-surrogate"))
+
+;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
+;; rest of slime isn't thread safe either), do we really care?
+(defun save-presented-object (object)
+ "Save OBJECT and return the assigned id.
+If OBJECT was saved previously return the old id."
+ (let ((object (if (null object) *nil-surrogate* object)))
+ ;; We store *nil-surrogate* instead of nil, to distinguish it from
+ ;; an object that was garbage collected.
+ (or (gethash object *object-to-presentation-id*)
+ (let ((id (incf *presentation-counter*)))
+ (setf (gethash id *presentation-id-to-object*) object)
+ (setf (gethash object *object-to-presentation-id*) id)
+ id))))
+
+(defun lookup-presented-object (id)
+ "Retrieve the object corresponding to ID.
+The secondary value indicates the absence of an entry."
+ (etypecase id
+ (integer
+ ;;
+ (multiple-value-bind (object foundp)
+ (gethash id *presentation-id-to-object*)
+ (cond
+ ((eql object *nil-surrogate*)
+ ;; A stored nil object
+ (values nil t))
+ ((null object)
+ ;; Object that was replaced by nil in the weak hash table
+ ;; when the object was garbage collected.
+ (values nil nil))
+ (t
+ (values object foundp)))))
+ (cons
+ (destructure-case id
+ ((:frame-var thread-id frame index)
+ (declare (ignore thread-id)) ; later
+ (handler-case
+ (frame-var-value frame index)
+ (t (condition)
+ (declare (ignore condition))
+ (values nil nil))
+ (:no-error (value)
+ (values value t))))
+ ((:inspected-part part-index)
+ (declare (special *inspectee-parts*))
+ (if (< part-index (length *inspectee-parts*))
+ (values (inspector-nth-part part-index) t)
+ (values nil nil)))))))
+
+(defslimefun get-repl-result (id)
+ "Get the result of the previous REPL evaluation with ID."
+ (multiple-value-bind (object foundp) (lookup-presented-object id)
+ (cond (foundp object)
+ (t (error "Attempt to access unrecorded object (id ~D)." id)))))
+
+(defslimefun clear-repl-results ()
+ "Forget the results of all previous REPL evaluations."
+ (clear-presentation-tables)
+ t)
+
+(defun present-repl-results (values)
+ ;; Override a function in swank.lisp, so that
+ ;; presentations are associated with every REPL result.
+ (flet ((send (value)
+ (let ((id (and *record-repl-results*
+ (save-presented-object value))))
+ (send-to-emacs `(:presentation-start ,id :repl-result))
+ (send-to-emacs `(:write-string ,(prin1-to-string value)
+ :repl-result))
+ (send-to-emacs `(:presentation-end ,id :repl-result))
+ (send-to-emacs `(:write-string ,(string #\Newline)
+ :repl-result)))))
+ (if (null values)
+ (send-to-emacs `(:write-string "; No value" :repl-result))
+ (mapc #'send values))))
+
+
+;;;; Presentation menu protocol
+;;
+;; To define a menu for a type of object, define a method
+;; menu-choices-for-presentation on that object type. This function
+;; should return a list of two element lists where the first element is
+;; the name of the menu action and the second is a function that will be
+;; called if the menu is chosen. The function will be called with 3
+;; arguments:
+;;
+;; choice: The string naming the action from above
+;;
+;; object: The object
+;;
+;; id: The presentation id of the object
+;;
+;; You might want append (when (next-method-p) (call-next-method)) to
+;; pick up the Menu actions of superclasses.
+;;
+
+(defvar *presentation-active-menu* nil)
+
+(defun menu-choices-for-presentation-id (id)
+ (multiple-value-bind (ob presentp) (lookup-presented-object id)
+ (cond ((not presentp) 'not-present)
+ (t
+ (let ((menu-and-actions (menu-choices-for-presentation ob)))
+ (setq *presentation-active-menu* (cons id menu-and-actions))
+ (mapcar 'car menu-and-actions))))))
+
+(defun swank-ioify (thing)
+ (cond ((keywordp thing) thing)
+ ((and (symbolp thing)(not (find #\: (symbol-name thing))))
+ (intern (symbol-name thing) 'swank-io-package))
+ ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing))))
+ (t thing)))
+
+(defun execute-menu-choice-for-presentation-id (id count item)
+ (let ((ob (lookup-presented-object id)))
+ (assert (equal id (car *presentation-active-menu*)) ()
+ "Bug: Execute menu call for id ~a but menu has id ~a"
+ id (car *presentation-active-menu*))
+ (let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
+ (swank-ioify (funcall action item ob id)))))
+
+
+(defgeneric menu-choices-for-presentation (object)
+ (:method (ob) (declare (ignore ob)) nil)) ; default method
+
+;; Pathname
+(defmethod menu-choices-for-presentation ((ob pathname))
+ (let* ((file-exists (ignore-errors (probe-file ob)))
+ (lisp-type (make-pathname :type "lisp"))
+ (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal))
+ (let ((source (merge-pathnames lisp-type ob)))
+ (and (ignore-errors (probe-file source))
+ source))))
+ (fasl-file (and file-exists
+ (equal (ignore-errors
+ (namestring
+ (truename
+ (compile-file-pathname
+ (merge-pathnames lisp-type ob)))))
+ (namestring (truename ob))))))
+ (remove nil
+ (list*
+ (and (and file-exists (not fasl-file))
+ (list "Edit this file"
+ (lambda(choice object id)
+ (declare (ignore choice id))
+ (ed-in-emacs (namestring (truename object)))
+ nil)))
+ (and file-exists
+ (list "Dired containing directory"
+ (lambda (choice object id)
+ (declare (ignore choice id))
+ (ed-in-emacs (namestring
+ (truename
+ (merge-pathnames
+ (make-pathname :name "" :type "") object))))
+ nil)))
+ (and fasl-file
+ (list "Load this fasl file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (load ob)
+ nil)))
+ (and fasl-file
+ (list "Delete this fasl file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (let ((nt (namestring (truename ob))))
+ (when (y-or-n-p-in-emacs "Delete ~a? " nt)
+ (delete-file nt)))
+ nil)))
+ (and source-file
+ (list "Edit lisp source file"
+ (lambda (choice object id)
+ (declare (ignore choice id object))
+ (ed-in-emacs (namestring (truename source-file)))
+ nil)))
+ (and source-file
+ (list "Load lisp source file"
+ (lambda(choice object id)
+ (declare (ignore choice id object))
+ (load source-file)
+ nil)))
+ (and (next-method-p) (call-next-method))))))
+
+(defmethod menu-choices-for-presentation ((ob function))
+ (list (list "Disassemble"
+ (lambda (choice object id)
+ (declare (ignore choice id))
+ (disassemble object)))))
+
+(defslimefun inspect-presentation (id reset-p)
+ (let ((what (lookup-presented-object id)))
+ (when reset-p
+ (reset-inspector))
+ (inspect-object what)))
+
+
+(setq *send-repl-results-function* 'present-repl-results)
+
+(provide :swank-presentations)
Added: branches/bos/thirdparty/emacs/slime/doc/.cvsignore
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/.cvsignore Fri Jan 18 06:05:59 2008
@@ -0,0 +1,15 @@
+contributors.texi
+slime.aux
+slime.cp
+slime.dvi
+slime.fn
+slime.info
+slime.ky
+slime.log
+slime.pdf
+slime.pg
+slime.ps
+slime.tmp
+slime.toc
+slime.tp
+slime.vr
Added: branches/bos/thirdparty/emacs/slime/doc/CVS/Entries
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/CVS/Entries Fri Jan 18 06:05:59 2008
@@ -0,0 +1,9 @@
+/.cvsignore/1.1/Mon Jul 24 14:13:23 2006//
+/Makefile/1.12/Mon Sep 17 14:04:27 2007//
+/slime-refcard.pdf/1.1/Thu Aug 9 09:18:50 2007//
+/slime-refcard.tex/1.1/Thu Aug 9 09:18:50 2007//
+/slime-small.eps/1.1/Wed Nov 22 06:27:38 2006//
+/slime-small.pdf/1.1/Wed Nov 22 06:27:38 2006//
+/slime.texi/1.61/Tue Nov 27 13:16:52 2007//
+/texinfo-tabulate.awk/1.2/Mon Aug 29 20:02:57 2005//
+D
Added: branches/bos/thirdparty/emacs/slime/doc/CVS/Repository
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/CVS/Repository Fri Jan 18 06:05:59 2008
@@ -0,0 +1 @@
+slime/doc
Added: branches/bos/thirdparty/emacs/slime/doc/CVS/Root
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/CVS/Root Fri Jan 18 06:05:59 2008
@@ -0,0 +1 @@
+:pserver:anonymous:anonymous@common-lisp.net:/project/slime/cvsroot
Added: branches/bos/thirdparty/emacs/slime/doc/CVS/Template
==============================================================================
Added: branches/bos/thirdparty/emacs/slime/doc/Makefile
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/Makefile Fri Jan 18 06:05:59 2008
@@ -0,0 +1,97 @@
+# This file has been placed in the public domain.
+#
+# Where to put the info file(s). NB: the GNU Coding Standards (GCS)
+# and the Filesystem Hierarchy Standard (FHS) differ on where info
+# files belong. The GCS says /usr/local/info; the FHS says
+# /usr/local/share/info. Many distros obey the FHS, but people who
+# installed their emacs from source probably have a GCS-ish file
+# hierarchy.
+infodir=/usr/local/info
+
+# What command to use to install info file(s)
+INSTALL_CMD=install -m 644
+
+# Info files generated here.
+infofiles=slime.info
+
+TEXI = slime.texi contributors.texi
+
+all: slime.info slime.pdf html/index.html
+
+slime.dvi: $(TEXI)
+ texi2dvi slime.texi
+
+slime.ps: slime.dvi
+ dvips -o $@ $<
+
+slime.info: $(TEXI)
+ makeinfo $<
+
+slime.html: $(TEXI)
+ texi2html $<
+
+html/index.html: $(TEXI)
+ makeinfo -o html --html $<
+
+slime.pdf: $(TEXI)
+ texi2pdf $<
+
+install: install-info
+
+uninstall: uninstall-info
+
+# Create contributors.texi, a texinfo table listing all known
+# contributors of code.
+#
+# Explicitly includes Eric Marsden (pre-ChangeLog hacker)
+#
+# The gist of this horror show is that the contributor list is piped
+# into texinfo-tabulate.awk with one name per line, sorted
+# alphabetically.
+#
+# Some special-case TeX-escaping of international characters.
+contributors.texi: ../ChangeLog Makefile texinfo-tabulate.awk
+ cat ../ChangeLog | \
+ sed -ne '/^[0-9]/{s/^[^ ]* *//; s/ *<.*//; p;}' | \
+ sort | \
+ uniq -c | \
+ sort -nr| \
+ sed -e 's/^[^A-Z]*//' | \
+ awk -f texinfo-tabulate.awk | \
+ sed -e "s/\o341/@'a/g" | \
+ sed -e "s/\o355/@'{@dotless{i}}/g" | \
+ sed -e "s/\o351/@'e/g" | \
+ sed -e "s/\o361/@~n/g" | \
+ sed -e 's/\o370/@o{}/g' \
+ > $@
+
+#.INTERMEDIATE: contributors.texi
+
+# Debian's install-info wants a --section argument.
+section := $(shell grep INFO-DIR-SECTION $(infofiles) | sed 's/INFO-DIR-SECTION //')
+install-info: slime.info
+ mkdir -p $(infodir)
+ $(INSTALL_CMD) $(infofiles) $(infodir)/$(infofiles)
+ @if (install-info --version && \
+ install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \
+ echo "install-info --info-dir=$(infodir) $(infodir)/$(infofiles)";\
+ install-info --info-dir="$(infodir)" "$(infodir)/$(infofiles)" || :;\
+ else \
+ echo "install-info --infodir=$(infodir) --section $(section) $(section) $(infodir)/$(infofiles)" && \
+ install-info --infodir="$(infodir)" --section $(section) ${section} "$(infodir)/$(infofiles)" || :; fi
+
+uninstall-info:
+ @if (install-info --version && \
+ install-info --version 2>&1 | sed 1q | grep -i -v debian) >/dev/null 2>&1; then \
+ echo "install-info --info-dir=$(infodir) --remove $(infodir)/$(infofiles)";\
+ install-info --info-dir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :;\
+ else \
+ echo "install-info --infodir=$(infodir) --remove $(infodir)/$(infofiles)";\
+ install-info --infodir="$(infodir)" --remove "$(infodir)/$(infofiles)" || :; fi
+ rm -f $(infodir)/$(infofiles)
+
+clean:
+ rm -f contributors.texi
+ rm -f slime.{aux,cp,cps,fn,fns,ky,kys,log,pg,tmp,toc,tp,vr,vrs}
+ rm -f slime.{info,pdf,dvi,ps,html}
+ rm -rf html
Added: branches/bos/thirdparty/emacs/slime/doc/slime-refcard.pdf
==============================================================================
Binary file. No diff available.
Added: branches/bos/thirdparty/emacs/slime/doc/slime-refcard.tex
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/slime-refcard.tex Fri Jan 18 06:05:59 2008
@@ -0,0 +1,123 @@
+\documentclass[a4paper,10pt]{article}
+
+\usepackage{textcomp}
+\usepackage{fullpage}
+\pagestyle{empty}
+
+
+\newcommand{\group}[1]{\bigskip\par\noindent\textbf{\large#1}\medskip}
+\newcommand{\subgroup}[1]{\medskip\par\noindent\textbf{#1}\smallskip}
+\newcommand{\key}[2]{\par\noindent\textbf{#1}\hfill{#2}}
+\newcommand{\meta}[1]{\textlangle{#1}\textrangle}
+
+\begin{document}
+
+\twocolumn[\LARGE\centering{SLIME Quick Reference Card}\vskip1cm]
+
+\group{Getting help in Emacs}
+
+\key{C-h \meta{key}}{describe function bound to \meta{key}}
+\key{C-h b}{list the current key-bindings for the focus buffer}
+\key{C-h m}{describe mode}
+\key{C-h l}{shows the keys you have pressed}
+\key{\meta{key} l}{what starts with \meta{key}}
+
+\group{Programming}
+
+\subgroup{Completion}
+
+\key{M-tab, C-c C-i, C-M-i}{complete symbol}
+\key{C-c C-s}{complete form}
+\key{C-c M-i}{fuzzy complete symbol}
+
+\subgroup{Closure}
+
+\key{C-c C-q}{close parens at point}
+\key{C-]}{cl}{close all sexp}
+
+\subgroup{Indentation}
+
+\key{C-c M-q}{reindent defun}
+\key{C-M-q}{indent sexp}
+
+\subgroup{Documentation}
+
+\key{spc}{insert a space, display argument list}
+\key{C-c C-d d}{describe symbol}
+\key{C-c C-f}{describe function}
+\key{C-c C-d a}{apropos search for regexp}
+\key{C-c C-d z}{apropos with internal symbols}
+\key{C-c C-d p}{apropos in package}
+\key{C-c C-d h}{hyperspec lookup}
+\key{C-c C-d ~}{format character hyperspec lookup}
+
+
+\subgroup{Cross reference}
+
+\key{C-c C-w c}{show function callers}
+\key{C-c C-w r}{show references to global variable}
+\key{C-c C-w b}{show bindings of a global variable}
+\key{C-c C-w s}{show assignments to a global variable}
+\key{C-c C-w m}{show expansions of a macro}
+\key{C-c \textless}{list callers of a function}
+\key{C-c \textgreater}{list callees of a function}
+
+\subgroup{Finding definitions}
+
+\key{M-.}{edit definition}
+\key{M-, or M-*}{pop definition stack}
+\key{C-x 4 .}{edit definition in other window}
+\key{C-x 5 .}{edit definition in other frame}
+
+\newpage
+
+\subgroup{Macro expansion commands}
+
+\key{C-c C-m or C-c RET}{macroexpand-1}
+\key{C-c C-m}{macroexpand-all}
+\key{C-c C-t}{toggle tracing of the function at point}
+
+\subgroup{Disassembly}
+
+\key{C-c M-d}{disassemble function definition}
+
+\group{Compilation}
+
+\key{C-c C-c}{compile defun}
+\key{C-c C-y}{call defun}
+\key{C-c C-k}{compile and load file}
+\key{C-c M-k}{compile file}
+\key{C-c C-l}{load file}
+\key{C-c C-z}{switch to output buffer}
+\key{M-n}{next note}
+\key{M-p}{previous note}
+\key{C-c M-c}{remove notes}
+
+\group{Evaluation}
+
+\key{C-M-x}{eval defun}
+\key{C-x C-e}{eval last expression}
+\key{C-c C-p}{eval \& pretty print last expression}
+\key{C-c C-r}{eval region}
+\key{C-x M-e}{eval last expression, display output}
+\key{C-c :}{interactive eval}
+\key{C-c E}{edit value}
+\key{C-c C-u}{undefine function}
+
+\group{Abort/Recovery}
+
+\key{C-c C-b}{interrupt (send SIGINT)}
+\key{C-c \~}{sync the current package and working directory}
+\key{C-c M-p}{set package in REPL}
+
+\group{Inspector}
+
+\key{C-c I}{inspect (from minibuffer)}
+\key{ret}{operate on point}
+\key{d}{describe}
+\key{l}{pop}
+\key{n}{next}
+\key{q}{quit}
+\key{M-ret}{copy down}
+
+\end{document}
Added: branches/bos/thirdparty/emacs/slime/doc/slime-small.eps
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/slime-small.eps Fri Jan 18 06:05:59 2008
@@ -0,0 +1,995 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%Creator: GIMP PostScript file plugin V 1.17 by Peter Kirchgessner
+%%Title: slime-small.eps
+%%CreationDate: Tue Nov 14 18:44:25 2006
+%%DocumentData: Clean7Bit
+%%LanguageLevel: 2
+%%Pages: 1
+%%BoundingBox: 0 0 252 104
+%%EndComments
+%%BeginProlog
+% Use own dictionary to avoid conflicts
+10 dict begin
+%%EndProlog
+%%Page: 1 1
+% Translate for offset
+0 0 translate
+% Translate to begin of first scanline
+0 103.29540259080517 translate
+251.14960629921259 -103.29540259080517 scale
+% Image geometry
+248 102 8
+% Transformation matrix
+[ 248 0 0 102 0 0 ]
+% Strings to hold RGB-samples per scanline
+/rstr 248 string def
+/gstr 248 string def
+/bstr 248 string def
+{currentfile /ASCII85Decode filter /RunLengthDecode filter rstr readstring pop}
+{currentfile /ASCII85Decode filter /RunLengthDecode filter gstr readstring pop}
+{currentfile /ASCII85Decode filter /RunLengthDecode filter bstr readstring pop}
+true 3
+%%BeginData: 57552 ASCII Bytes
+colorimage
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcDnQp&=1TJ,~>
+JcDnQp&=1TJ,~>
+JcDnQp&=1TJ,~>
+JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~>
+JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~>
+JcE=]rVd0(rr2loqtg-`p\+IV#PRoeq>:*grpKf:~>
+^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~>
+^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~>
+^&S*2K`;\ar;-0]p@n@Wp@RnBl/gp^gtM_[%,0ImiT04hnFZMQrVl?eJ,~>
+_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u
+Xg>RRajSr)m.C/Qo)F4~>
+_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u
+Xg>RRajSr)m.C/Qo)F4~>
+_#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=<e0hVR5Pj58P;ahkZtYGnAsUCF&u
+Xg>RRajSr)m.C/Qo)F4~>
+_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU
+p&>['q!?_R[B6U<\@8]>TW+a/a2[rL%+WD>YGn1p]$&prp\j^`J,~>
+_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU
+p&>['q!?_R[B6U<\@8]>SYMdk^:j@0%*ZE"VkT`^]$&prp\j^`J,~>
+_>al?q!dM,hr<khq#'=Ts8E&tr;?HlqY^3lr;HTmrp0RjrquQ`naQ,CqYg!b$NBttna#E'me-GU
+p&>['q!?_R[B6U<\@8]>V6mGObffhD%+WSI]!S?7]$&prp\j^`J,~>
+h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\
+qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrs\o'mFAPViU?6RSZ0Nnmg%djUU8G5
+p\jaaJ,~>
+h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\
+qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrs\o'mFAPNg$@t9Q_M(XlNc+VT=!#1
+p\jaaJ,~>
+h>[WWrVZQgrV-NkqY^<ko`#?tp?:)F[BI!Uf')i*lMh(eqtTjUnF$;Brp0RM%di]RoCV_Lp\=R\
+qu$Elo)B*rq=<_'da6P&m.UALrs\o'o&\EB_8O^YmeHbTrrrDumFAP[rlbJ^Vm=2*bQc%f[*e.4
+rUg,?~>
+i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo*]]&><]WTQDp\jIY$N0Yek2"S6bK.`Erl4rX
+&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYYH=n8d,t$!pAYX%qXE=XWP-?nW4LRHq>U0h%/ohS
+[aX<je^`UCkMY^W#he/'d]LsbqYp0fJ,~>
+i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>Us'pZTo'Ze=ZtZ`DC8p\jIY$N0Yek2"S6bK.`Erl4rX
+&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFYWMcZ'd,t$!pAYX%qXE=XVR4(PUUo%Cq>U0h%/ohS
+[`n%#kND*rlfmd!#jCO?bH'(YqYp0fJ,~>
+i;XMjrVH<]nEfB#j5]4`lgOH>q>C3jq>UWspZTo0_>_X^_6_GNp\jIY$N0Yek2"S6bK.`Erl4rX
+&]r8De_&U3i8`tbmIBiCqYgEerser%mFoFY\[SrTd,t$!pAYX%qXE=XXhr)uZ+ANQq>U0h%/ohS
+[`cFp[C*Zc_S#6C#e.Ieb-TO`qYp0fJ,~>
+ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=YujOr):jPR)inGDVQ#lOAYeA&,YUT+6j
+rMKRl&ZM@nU8Fur\%T]%dFmOFo_SR^rt#,*mFJYMn*93*d]1LSp\jjd&,YqR];b5Zi8F"CZIeRB
+rqZR'qsDY1lH-<4XLlTm]<(D##dM"dh:&pnpAO[aJ,~>
+ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=SolKIEplJ&AinGDVQ#lOAYeA&,YT;)+R
+&tu(iSt`*_Z+%Eab0eo%lh(&Qq#:m(qX)k@WpB$<mE;ENkkG&Mrt#"th7KHKlKRR#^9ZAZqu6Ek%
+/]G:VsNL&hr!DRj5K@^#iO\'l-$WrpAO[aJ,~>
+ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=kd^ULV[^W<b3nGDVQ$iK\\eA&,YXL#19
+Yl1d*YS+4IURn3WX0K.I_ogB[ip675rqQL(rqc$5[(=K"`5g$'bNS^!p\td$o%gpab.kU%a2YF:
+n,*+[rsekmc*tWnTq@sSXfJ=km@FTWVQdYS\`*8\p&BO~>
+jSp5!r:odDfu^e(TW#$4`5KX*VPBrn_U.-&nbE%]rr3Q/q<,T+jM8%%Z,#G4_<:Xnn,E[lpZKc$
+a7&Kap$)PFrpL<S_o0']WM$/ubMVgcrqZR)r:8UMa62!paj&Z!WmpM7q#:p(p>j&hlI!DZ]?TEJ
+]]&S_qYq$(q<,Q6i4G)-M3+3lOR.f0N0'^WmB"n/r:U)?~>
+jSoYfr:odDfu^e(SYE!prk&ZETV&$d_U.-&nbE%]rr3Q/q<,T#lJgaZi8X%._<:Xnn,E[lpZKc"
+^?b+Po^)SC%GA>*Yb%S[Vmjk,nG<.[rt#%ugU4c]kN(^cl.W)cn,)n[&H2=`_5$AZio/kXlE\(]
+pAOjf%K?1d^qT'lg=Os1gtUQLf*L$_h<"%&f(&\2s*t~>
+jSoYfr:odDfu^e(V6RMKrko5ZYH4P+_U.-&nbE%]rr3Q/q<,T1^SmiuTr>`A_<:Xnn,E[lpZKc*
+`luZIou$jQrQG\e`4`=ZUo1]FhsgLAq>V!'o%URl_R6MJYe%o[eF3;0rt,/&jMA1@ZDaXtYeRud
+iV*6Hrso&(kJ5*MVO*gCQ^<u(SF)jQS!TSJa0jLgr:U)?~>
+jo5bfq=3Rs^o=!Gi9omnrSSgZlL"&YYFr&9f&uZ$rr<#tp><.DeZ=^dN2tLtZ/>9Sn,E[jn'nDq
+i76B&ouR3]rm_J2i8E\]lL+,hXhEQ]r;-F*rqPZpWTqU,S"$+djLMq`p\t!g&GtqFVs_s0PE:m'
+dI*aUmeck\%0$%_\AdC<OF21uK7NrKs+:9-!/p]8re^Z,$@I,DJssdGY0lb:p&BO~>
+jo5bfq=3Rs^o<g:g$J(krTPHim-X,NVk(!.f&uZ$rr<#tp><.@kMOqDf\blXZ/>9Sn,E[jn'n>j
+l0%6kp#H,8roXCIl07L4liue!VnLpWr;-F*rqPZpU?psugt^`FlE\(_p\t!g#5dl<V!R7#rn7S5
+k3Sbfmeck\%0$%_\@h(bg="<qeC4EFs4%)#!8./%rn%2"$I[>KeD0-OVpY#3p&BO~>
+jo5bfq=3Rs^o=9Obf[l@rOa8f`5g*>\>6:Ff&uZ$rr<#tp><.![@`qYS"@%3Z/>9Sn,E[jn'nV`
+]X>/OorS5"rj<3E]Y)"t`6-<H\%UVgr;-F*rqPZpZc&u<Q^=/>^V@GAp\t!g&GtqFXNIi=QC!r.
+ZH9&lmeck\%0$%_\AZ%WQ`IKoUS[sjs.fUb!1WhPrgj(a$EL>7UR/+$\'a^Cp&BO~>
+kPl%kr:]F/_5=EomGQ[Fai+.i+Mc+De_oWYdBTXhhspRBs8DWFVsi0;M04ZUeaKEjp&4C[$3'b_
+^rPBFXK8,gRfK>bX:DMI]>2P1dFI(<^;T1/rql^-r:8L?i7YAoK7f#]eaK<anbi7`')q^i^q/UB
+PC(a)n.P/$(f]]Akequ7B0pYrX"i4G(uBk_L(Jr,SXR]EKoqRZ[,s-a:VNerU]aQg"Znbi([J,~>
+kPl%kr:]F/_5=0amHNisjQ$3t+QDJDkNV=!af25XhspRBs8DWFVsEO'f?`(+kNf&#p&4C[$3'b_
+^q]-mhr!8_g]641h[\T'iSrqZk3)!q[`%>'rql^-r:8L?g$%AHeC<+-kNeqonbi7`')q^i^p<7b
+g=+Kug>_D&]]Akequ7B0pYrWol/C@Eb0%rPeCWF0gu%#IqVhG2s4dt8g"4j2jQrnrnbi([J,~>
+kPl%kr:]F/_5=`da1SmeXfMDt+K2EH[CjB!agn@hhspRBs8DWFVp)Q@S@"iY[EPQ'p&4C[$3'b_
+^rO*bT:_SFQN3QTT+7QlVPpW!ZF.9^_o1^4rql^-r:8L?bdX:8USFBO[EPGsnbi7`')q^i^qd^`
+QDgj_QDhR4]]Akequ7B0pYrX!]V_$raiV93URdd=Q_'eBqPO7`s-F([R(a)Tn8Xi.d"nbi([J,~>
+kl21mqXW[jYG^=Ag!..6VONkLO<BaVTrblEdG=!DXM<]cr;Z`ffq\#dXGM(VX4?[6g%>74rsA]!
+iNr"'XGMdfon*7"reV,DOH>ZqS#39qeaKToo_n^f'E7jn`i87FRtGWtJssdGVoS*!rql^.rUo!M
+dG;6kH>.S]Z.\'7g%51>rtPJ-j0lna]9%DS>]54_X1HBne^`@Li;V:,a9oMeX/ii!jIG&urUp2@~>
+kl21mqXW[jYFsS7kiLd]hV?l`g)o,+hr3VXl0I$"^Ynb^s8DTCU[.+#f?`(+kNenro_n:Z$3'\X
+Zg6f3f@SRGe,\)!f)XJ&gAfq6hV[;Tl`Ak5rVZ[/rqbp"U?psreBH.dguRgqa6NO#qu7<-p"cgo
+l/C=Cb0\f!kh2rgoDSRd'`Rmf[_1k`g="-?bgbG*iT0(_kNMd,roa=Bs5F"8#3"t'QJM33p&BO~>
+kl21mqXW[jYHc<g\$2a'S<oN>QQVT\R\-IXZF[os[D1Ylr;Z`ffqZd!T:E9ZT!ce;g%>74rsA]!
+iNpb9T:DFFoqMMYrgXIfQ^=#)Q^j\C[EP`,o_n^f'E7jn`j3ObQ_V:/UR/+$YfH&*rql^.rUo!M
+ah"78Y0!r<Tsr7Fg%51>rtPJ-j0ln=VO+@*`4r(6Su/Wl[C*L?]`,>=XU:r#St;h"fsBN,rUp2@~>
+l2M=oqXE=XUVuHN`3H"tN/*%9rHo`:K8#/DQ);".g$5``lh^VZo[oo,eZ=UMM6#1qU=f,:nG`am
+pY`=FeZ=W(K)0BuF*2bUG^OmfK7er9R`Octe+*A6rtGA)i3^G\]9%DSBRGoQi5E+ap\t'i')_:K
+TC:=3M03<JKqQ]XUWr6(qu7W7puK!)i4G(uBlATlaOT56lL43!_SEt)_na(en,MY[i8)r6i9cK,
+lM:GPs*t~>
+l2M=oqXE=XTtKaUj5AbIf[eR$rR)h;eCE1)gYUoLkj57klh^VZo[oo(kMOn;fAGcWU=f,:nG`am
+pY`=BkMOnfeG@B%cHjndd*g@keC<($guRh$e+*A6rtGA)i3^/]iS)`&ajSo%l+FLbp\t'i')_:K
+TBk[tf?_"Pe_T?ST?Zg$qu7W7puJuul/C@Eb08AjjQGdom-Euj]!f)[]=,0Ili6;Yl0.<nl0Wu"
+lM:GPs*t~>
+l2M=oqXE=XWPl`aX.buKS"?COrMq'>US43EQ(4VM\&>c!lh^VZo[on^[@`trSY!75U=f,:nG`am
+pY`=#[@`ucU\_\;\$W<=Z)aq(USFENQ`\3:e+*A6rtGA)i3^G8VO+@*b,^o,]Yh5<p\t'i')_:K
+T?O^8S@$>KTpi4+XNg21qu79-puK!(]V_$rahOU;XgPg[`;[sb_8jX6_T0^rbl>Tg]XkMY]Z7S&
+lM:GPs*t~>
+lMhLrq<ltJU#+_LZ'C9%I!BpeJqs>^+GGDrH$k-tNg6m"n%.TTrr)KAU@6X6M04ZUeaK6bo_n:Z
+#QFM[][>QDT_b)XJoCQl!b$#!r/(B(#,]f9YL;q<r;RH.n^X?%eZ=UM(a)q9eAZ.\'6g%>7?rtG7p
+aJ\=FRtGWaCk.ehkH;Ybq>U<l.fT8,^8^;6Q%3e)R`Od-_ip@!CNQauDmZliDJX'$Q(l+An*e,M
+I_bURo`'F~>
+lMhLrq<ltJSD*5gi7lo7da6CjeCOWN+P"uidF-Lpg"YHJlal0Prr)KAU?h""f?`(+kNekpo_n:Z
+#QFM[]ZKEsh>5n-eBIif!jg,#r7Cns#2\M/WRC;6r;RH.n^X?!kMOn;\\?GCi98jmg%>7?rtG7p
+aJ%t]gsjQFbL>5+l__M^q>U<l.fT8,^7X`OgXFBrguRh/]7l#@=_+^A?F7(F>Zt61LRbiolg)'+
+DS#K<o`'F~>
+lMhLrq<ltJWQ2ZRTp;+@X0Jh)US%OV+JGR/Y,eCjR?aJRbdum1rr)KAU<L$;S@"iY[EPAto_n:Z
+#QFM[]Zds^Rei?OUV?ZF!li!Mr13e]#+W!(a)]$g*Gr;RH.n^X>W[@`tra2kNTTsr7Eg%>7?rtG7p
+aK`[cQ_V:6_PWU!_RIAFq>U<l(]O6n^:M1^Q)26jQ`\3B_RmL`Yd(C=[JmNDZa$a:]rT5tbfn2@
+]@Z]Qo`'F~>
+li.Xtq<lnDVsVmDRuDlBF+/n$Q("TLX!"((P)bBSJqBZ,i:488p\t-`fV7ibXGM(VX4?[5f_#.2
+rs&>ecA:l@c2,KfRt>Q`91rN.JsuV<rL*qfdI*[[oDSUe'Dh%9W9VKoK5Y"&F,-X?m[qkpr;?R/
+rqPQc\E(GhIVW)"I#tqt_mSLurqudGrqblrS*J+bK7]Q5lAK2SF*;eSL>RB+iSf03H[9p[_/X@p
+DfU)Zc27M4s*t~>
+li.Xtq<lnDT^Cn#gt:*&cI1:qgYCZbh]Ub1g=b*/eC<=5l0>_:p\t-`fV7]phq-3+hrj="f_#.2
+rs&>ec?\g(a)jne$EgsjQEBP=6deD0uZrS.V6k3SPhoDSUe'Dh%9U?psreBFepcIUk7m$uGkr;?R/
+rqPQcYNk-$e'"0$db<[E]X?bnrqudGrqblrOmM/aeC<:7m!_j6@:Wt`G2I%MiSeNdBkV*h_-^HL
+?!q8ia8>l.s*t~>
+li.Xtq<lnDYfF&HQ^ahV\>Z$jQ'\$?SfjJgQC4;9USF9T][XCLp\t-`fV6TtT:E9ZT!ce:f_#.2
+rs&>ecF_-+YkkI.Q_V:5]tMA!UR1nMrKd_YZH9E)oDSUe'Dh%9Z,Ec2UV=^e\=]:saeR5Or;?R/
+rqPQc]t^M3W5ZZsX-fcs_mSLurqudGrqblr[)B)5USF0X`3cMF\@]Gh_r&;IiShVh^q[Rp_7$_Q
+[(!`gjSSrKs*t~>
+m/Ie!qXE4IV<Z=&OFqdrIYWcWX2N*,rm`.9aM50aVOEsH]'dSQk5##To[oo,eZ=UMM6#1qU=f,:
+n,EUjp#:(\iU-L,$-AZgDd6OcJssdYec!PndFH75jS/ZPrtYP.jh&%`^ls4_=^5lsR`Ocj`9R3u
+rVmT1p"Z[sh6r>iB2rJdMm:snWnd:Gqu7Q1lG]=Zad[p7R`OcVDUX#aJV&sWK7ipmKDpH1JUls4
+I,97"J<87ZoDa=~>
+m/Ie!qXE4ITBt[rg=4Kndam%,hrEe[roYEcjPo.UhV?oBiU".jk5##To[oo(kMOn;fAGcWU=f,:
+n,EUjp#9G<g?nb'$09mkbbh5\eD0-_kPaHGk3'LOjS/ZPrtYP.jh%_]inDl)RAJ-WguRgo`9R3u
+rVmT1p"Z[ll/C=C`JhOXf\kuHWnd:Gqu8)@lG\tRjP887guRgS>gmJ+DfC7$EH1aIEH,r:Df4cS
+C>N]ADLg"2oDa=~>
+m/Ie!qXE4IYJdZ8Q_Uh#W1TWNSu]!!rj<lQXf/"dS<oS2VTI6#k5##To[on^[@`trSY!75U=f,:
+n,EUjp#<NtbfBRu$*BPh^;Rt)UR/+\[Jd33ZF.Q_jS/ZPrtYP.jh&4@W0XC$_o0<bQ`\3/`9R3u
+rVmT1p"Z[k\tb[rahc''S"[=8Wnd:Gqu8)@lG^0LXd>fXQ`\3:ZdZe1`lH?uaN4,MaN2EB`l7/Y
+_;<#G`Qd]IoDa=~>
+m/IdtoA@0XlH,`THuEqGM5I?$e`Z5crpLuslK$dOdE'DRea@b2med"^o[oo,eZ=UMM6#1qU=f,:
+n,F7(qso,XGH%U-Pbt7>Q)D`nK5Y[[R`NR_rU9^M"n&Y&\FBCnrtYM*hQG8^[Z5ZH<E<d\OLjAg
+\`EPbrVmT0n^F)ueZ=UM@o6]XM6#1qT[iW3qu73'lc,L\ad[p7R`OcYF6%rPKE[S=Kn]O*re:?)
+#l91+p4J!NP1K4(J,~>
+m/IdtoA@0Qm,[!Rd`fq]fA>EIkNhL$rp(]om-<ftk2bUbkNlp1med"^o[oo(kMOn;fAGcWU=f,:
+n,F7(qsnN5B;D;XL7b&iO.YLgeBH.dguQG\rTjCJ"K/W4nGE.`(&dg^Y0-"fg!RctOic&*iT\"c
+jS8`QrtPD$e"5mghq-2bI^m_Uhrj<ueai\9rttUu`focMgsjj/jQqS/jD]-[F+aI5F8l1;F8p7d
+qJgNKEH-#Od.73e~>
+m/IdtoA@0a`3#K"X1l?USXc:W[DKl(rlcM*`4rmkZE:75[E5l)med"^o[on^[@`trSY!75U=f,:
+n,F7(qsqV9['?sN]W\HKT!b\eUV=L<Q`\!;rQP5Y"j+Tfd.$r1rtYM*hQFu3URA:,_8=?qR&7O7
+\`EPbrVmT0n^F)R[@`tra1o[%SY!75T[iW3qu7N0lc-BOXd>fXQ`\3<\E(]Pai`!0b0'__rQ>/^
+#l;W`p;k=sd-^E(J,~>
+mJf3GpufYlmEM>YF(oQ8M6#%Sma%ntS"+2]Kp9'nn*]K+mGF7PjS&QPrUea:n("LrFc!0Ln"SJ,
+rU0\3rqh:sLXXIiFiM79Q&Y(NRtH<]aQe[mBPM7MQBd`$HZRi\q>U<l(&d^SU@6X6M03<*<+^E9
+[b]?6hY-sIrtP=qa/A4ERtGWa9jVgnTZukucL:Z-rt"tl`guD:RtH<]aQf"3l(a)f.j"dAt?L&_2M
+K`h@/L&V(*!L)+*s*t~>
+mJe4+pufYhmH*0ScH=AWfAG`Rm)YrVR@I?IG(m-?li-5fmFmD,jS&QPrUea:lf[0Wce%(;l_<&(
+rU0\3rqgYOGLOcGA&c>kQ%//]gsjj/jQq=l<`iImLkgbBC15c3q>U<l(&d^SU?h""f?_!VMT!oq
+iTSCdhY-sIrtP=qa.Ve[gsjQFDQD%4h<"$qcL:Z-rt"tl`focMgsjj/jQqV2l>llF"bZhrF8u:;
+Es)G`F8l/[!JAbis*t~>
+mJf3GpufYta0;#+\&lClSY!-paiCa#Tq&9S\@]DsbfRfAa3)0.jS&QPrUea:bdF(5[%3erbbEb^
+rU0\3rqjaS`7)rA]#MRoQ*nQ4Q_U=BXi.TFXfnps^:h4p\%()Kq>U<l(&d^SU<L$;S@$>O_9&jJ
+UUnOLhY-sIrtP=qa0ERbQ_V:6]u@UWR]si4cL:Z-rt"tl`jWgfQ_U=BXi.l`lH0%J"jm:lb5_M=
+aoh[db5VC_!RU6)s*t~>
+mJf3DnC=Jqfs-K\AT)sQX4?XAG&4^3cI7'eG'(<5CNukFWNp\qoDARfrUea:n("LrFc!0Ln"SJ,
+rU'V0re,obna:pXlK*8mYiNT`IY+$0lB,q,H$Rh^G'8(UIdkeaqu7E.m`hKnc(Ti2?VO@+Fc!0L
+n"\M+rVlg3rqGKa\E(GhIVW(Z>]54_aQfYBlh^MY&,PV3Sa+=dK7]Q5lBHGWK`6Z/PQ->js8VtM
+"94(/s8I]QPLf=)J,~>
+mJf3DnC=Jjkht+?^Wb-Xhrj@&AQlWScI6FSAR`5U=_FOdV6XWIoDARfrUea:lf[0Wce%(;l_<&(
+rU'V0rc<(0na::4lK)Z\V<['oe(!16m"8PRB4oY(A7T7bD",[Iqu7E.m`h?jjk\J3XDiQsce%(;
+l_E)'rVlg3rqGKaYNk-$e'".kV9IHEjQrPZlh^MY&,PV3PO.AceC<:7m"T$9ErL+`KE$"6s8Vt;
+"93F`s8I'?K@'2hJ,~>
+mJf3DnC=J]\"T:raM4dHT!c\TZ*LpOcI9MU]XbV[YdCdOZ*M!YoDARfrUea:bdF(5[%3erbbEb^
+rU'V0rlW=,na=B8lK,a^`4r7:W2#]]`4<4d^:r%.]=Y_j_slphqu7E.m`hfQYaV8s`P0+-[%3er
+bbNe]rVlg3rqGKa]t^M3W5ZZe`4r(6Xi.E_lh^MY&,PV3[`#;7USF0X`4W\Iao9Edd/V82s8Vu=
+"96Nds8L.Ad-^E(J,~>
+mf,?IpZ9/nkJWX9D/Xf`X4=@sDfpBeJ+)r[nUQ,NI!U%_GLYK!K)>QIs8DTBU@6X6M04ZUeaK6b
+o_n.Vs+M8Pr;2/#q=B!@_;MqeI"e6<m?D^@JV!@iJ-1CUqpkTD(B40p_klY?RtGWa928l9LSiJe
+S^6d&rr3c4o\-=lh6r>iB2qN,Ck.ehkH)G]q>U<l&,PV3Sa+=dK7]Q5lBHGWK`6Z/PQ->js8VtM
+"94(/s8I]QPLf=)J,~>
+mf,?IpZ9/glf6aKbfnMhhrgeI?"@X0D=@%7nSW4*C1q5)A^oRRE;TY7s8DTBU?h""f?`(+kNekp
+o_n.Vs)T97r;1MTq=A@.\*;l*dad18m=o(cDf>/aDJjB3EVn)ZrtbV1l,0+ZjP88/VJ(+WcIUk7
+m$c8hr;Q^3rUegDam%d;dD_&OT$,U;j6NPVkP>,Trt"tl`focMgsjj/jQqV2lZ2uG"bZhrF8u:;
+Es)G`F8u5\!JAbis*t~>
+mf,?IpZ90"_Q/ru_S<.=T!c;<[(F*6`:*9;n\rH._8!\/][YfVa8>l9s8DTBU<L$;S@"iY[EPAt
+o_n.Vs2lG1r;4UXq=DG0aLnC:X.buda1]%#`l@Pg`Poj;aSYB%rtbV1l,0[BXd>fs`P'"*\=]:s
+aeI,Mr;Q^3rUegDah"78Y0"Mm_nr:9X2;9ZkP>,Trt"tl`jWgfQ_U=BXi.l`lcK.K"jm:lb5_M=
+aoh[db5_I`!RU6)s*t~>
+mf+X3o%0etfs-K\Dg[YXeW=TiH[gYBK`(e%r.KauJqARBJFW;bK`:uN&H27RU@6X6M04ZUeaK6b
+o_n.Vs+M8Qs8Re,rqCiK_;MqeI"e6<m=oh8KS9:$KE?l-f),I_rqPQb`Se@iHtcYO93cCeR`Ock
+`p<L#rtbM#c_'XQVMB5$:IS;tI#tqt`4+e%rqud,qWc%jlH,NJJssdGP]c;Fre1N>s+Q1,s8.KP
+s+Q1,re1B:f(/ik~>
+mf+X3o%0emkht+?bgP5(kCZrJBl.haEr>lWr,QiQEH#jbDt3L?F8l1=&H27RU?h""f?`(+kNekp
+o_n.Vs)T!/s8R.]rqC39\*;l*dad18m<<,ZEcV*VErU1]s3UZC(B4*i\\.1cg="-,;J)cLeD0-O
+T>p3nrr3c2n'@Njk2+\7ZZf6.ajSo%l+FLcq#:3k&,PS1PO.AceC<:7m"T$9ErL+`KE$"6s8Vt;
+"93F`s8I'?K@'2hJ,~>
+mf+X3o%0e`\"T:r^T3a![C*<O^r4:gao)+[r5m(UaN)<h`pr`Cb5VD?&H27RU<L$;S@"iY[EPAt
+o_n.Vs2l/)s8U6arqF:;aLnC:X.buda18k%aiXJZaoBKas6]^`(B4*i\\u.XQ`J6F]"GtrUR/+$
+YK#o)rr3c2n'@fPZCIMq`kK%$b,^o,]Yh5=q#:3k&,PS1[D]26USF0X`4W\Iao9Edd/V82s8Vu=
+"96Nds8L.Ad-^E(J,~>
+mf+U0lc?'jad[p$I#tqtNbs#iJqSgVL&_1,s+Q1,KnP-WK`(h'L&M#_rUea:n("LrFc!0Ln"SJ,
+rTsRaKbosQs+Q1+pO'9_i4G(uM6#1qBR#)]L&_%(!WUaJs"OHGhQOiT]9%DS=%5\^C4;>\jLDnc
+q>UEnq<,SskJWX9D-KS#<bQlB]&:H/htI'Jrt,2+l,0%Vad[p7R`OcYFmF_[Ka!\?Kn]R,qh5.P
+Kn]R+K`RCgo)F4~>
+mf+U0lc>gejP88/db<[EJQl`&E,p%!F8u8]s)W8]F)uC"Er>oXF8c+MrUea:lf[0Wce%(;l_<&(
+rTsRaEu0K/s)W8\pM7(Cl/C@EfAGcW<bH>kF8u,Y!WUODs"OHGhQONTiS)`&P#>DLbL5,(lEIta
+q>UEnq<,Sllf6aKbb&<?Oic&*iT[qWhtI'Jrt,2+l,/\NjP887guRgVA*\17Es73rF*%B]qf;l>
+F*%B\Ergp?o)F4~>
+mf+U0lc?BMXd>fsX-fcsZa.9^a2uL'b5_Las2rLab0%j(ao).\b5M>OrUea:bdF(5[%3erbbEb^
+rTsRaaqrG)s2rL`pVO5W]V_$rSY!75Y.hotb5_@]!WVQas"OHGhQOf/VO+@*_Rd@s`i,3%^V.>C
+q>UEnq<,T'_Q/ru_Sj*u_TJpHVS'aKhtI'Jrt,2+l,0pIXd>fXQ`\3=]'IK;ap$/lb0'baqoT$@
+b0'b`aoTlVo)F4~>
+n,FF-puK!)i4G(uI#tqtcXh3IJqSf2s+ULQL&Zj\s8I]Us+ULQKn]L*&H27RU$pO5M04ZUeaK6b
+o_n.Vs+M8Qs8Re,rq:`C^u2hdI#4oSmqI'!KSBI'K`V5)qu8AKo@Tl-eZ=UM@o5Z`<bQlB]&:K4
+i:m6NrUo'Q_r/.gHtcYO78RH9M6#1qVqUeArVmH.q<,M^lH,NJJssdGP]c;Fre1N>re6()rV_EL
+K*_7)KDU=UKp1*Ys*t~>
+n,FF-puJuul/C@Edb<[E`Dg;_E,p#@s)\5?F8p<&s8I'Cs)\5?F*%<[&H27RU$Ln!f?`(+kNekp
+o_n.Vs)T!/s8R.]rq:*1[cuc)db!C>lW@e=F*%BYErl<fqu8AKo@Tl)kMOn;\UHe?Oic&*iT[t\
+i:m6NrUo'Q]BS;.d`R_N:jfe!fAGcWVqUeArVmH.q<,MSm,ZsOeD0-OL1BOirc86qrc</ZrV^d:
+E<GuUEVo`V!JAbis*t~>
+n,FF-puK!(]V_$rX-fcsbH&1ka2uKHs2tBAb5]W,s8L.Es2tBAb0'\_&H27RU!0p:S@"iY[EPAt
+o_n.Vs2l/)s8U6arq=13aLnC:X.>iibceb$b0'b]aoVP0qu8AKo@Tk_[@`tra1o*p_TJpHVS'dP
+i:m6NrUo'Q_n;k5X3&5i]"c:mSY!75VqUeArVmH.q<,N!`3#B$UR/+$]XmFNrlPDkrlWC^rVak<
+a924YaSYtZ!RU6)s*t~>
+n,FF-p>2t1fs-K\I#tqt^1MM:JqJ`0qh4nGK`6[Zs8I]Us+ULQKn]L*&H24OTC:=3M04ZUeaK9d
+o_n.Vs+M8Qs8Re,rq1W<i7YAoG_rKOmqR0#KSBI'K`V5)qu8AJn'@TndAD\?@8BKa;Ik!0Z.\'6
+g@Y@Dr:/7.n("LrF^n9A78RH9M6#1qT%*?/rVn;FpuT-,i4G(uJssdGP]Z)?K7nl=pO\"ho7;FB
+Isuk,I=CR8K7oH>o)F4~>
+n,FF-p>2t*kht+?db<[EZrCOOE,fo=qf;W5F8g6%s8I'Cs)\5?F*%<[&H24OTBk[tf?`(+kNenr
+o_n.Vs)T!/s8R.]rq1!*f]_8Gd+@1<lW@h>F*%BYErl<fqu8AJn'@Kik2+\7ZZeT0K>,^bi98jm
+g@Y@Dr:/7.lf[0WcaeL::jfe!fAGcWT%*?/rVn;FpuT-$l/C@EeD0-OL19=cEH6&MpMk0Eo5AMa
+D/=%KCM`BWEH?cZo)F4~>
+n,FF-p>2sr\"T:rX-fcs`N6Yga2lBEqoSd7b5TQ+s8L.Es2tBAb0'\_&H24OT?O^8S@"iY[EPE!
+o_n.Vs2l/)s8U6arq4(,bdX:8Z(7Jobcee%b0'b]aoVP0qu8AJn'@cOZCIMq`kJmm^rWdMTsr7E
+g@Y@Dr:/7.bdF(5[)]qo]"c:mSY!75T%*?/rVn;FpuT-,]V_$rUR/+$]Xd4HaN;NKpW1DIo>\bg
+`5BLQ_Sbc]aNDlso)F4~>
+n,FF,p"QG6eZ=UMF,-X?h/I4SH[^Hom""TrK(X_Jq>Q$Nre:CPKn]L*&H)(IS+"n/M04`]g$klm
+p&47Ws+M8Qs8Re,rUkK6n("LrFc!0LmqR0#KSBI'K`V5)qu8AHlc,jfad[p$>Y@sb:h"R(X4?[/
+ddd87qWc%tlH,NJDd5q3787*.KqQ]XU!<$&rVn;FpuAj%i4G(uJssdGPB#B,It)p(iSJq6eTc7[
+FE2B2EHB?NItIULo)F4~>
+n,Fa5p"QG2kMOn;cIUk7fO.rqBl%X'lu)=`E:n3jq/ULsrcA,>F*%<[&H)(IS*T7pf?`+-kj,,"
+p&47Ws)T!/s8R.]rUjm%lf[0Wce%(;lW@h>F*%BYErl<fqu8AHlc,UajP88/VJ&%nI(7MShrj<q
+ddd87qWc%mm,ZsObbf'$:i<>Ye_T?SS^$U"rVmE-puAirl/C@EeD0-OKj`^8D&$l4iSJ;$eRi?%
+@UWWR?X_/mD/oL#o)F4~>
+n,Fa5p"QFh[@`tr\=]:s`iQMZ^r++/m)AJba7[Npq8pb$rlY9@b0'\_&H)(IS'8:4S@"cZ\'Lr*
+p&47Ws2l/)s8U6arUmt'bdF(5[%3erbcnk&b0'b]aoVP0qu8AHlc-0IXd>fs`P&[k^W3^PT!ce4
+ddd87qWc&(`3#B$^;[e#]"Q(pTpi4+Wm0u/rVmE-puAj%]V_$rUR/+$]=6Sp`"g20iSMB&e\/T+
+\[])X[^aPs`5qlDo)F4~>
+n,Fa5p"QG6eZ=UMA93O'dG9@fDK9iAaEGnYHJ*XmjaVi5q1S_HKn]L*&H)"BU[?="Km\uni8L]k
+p&=:W(kn1Rs+Q1*oQm;$eZ=UMM6#1qC3kJbL&_%(!WUaKs"XNJk.J4b^ls4_=[u+a93cCeR`Ocm
+amAm&p>NEti4G(uBiePK<_H\9JssdGUr;QprVn;FpYrU!i4G(uJssdGOD;JJFE;K4Z`\,>Sp-Kc
+Pc_pC_T/`rGCK;:o)F4~>
+n,Fa5p"QG2kMOn;^<Y<dk1O`U>[V#NaCNWGB\@*7j_\pTq/ZH6F*%<[&H)"BTC(are^E11l.N)l
+p&=:W(it?0s)W8[oOt#ckMOn;fAGcW=D2YpF8u,Y!WUOEs"XNJk.Iq`inDl)R9F2aAu3`$guRgr
+amAm&p>NEll/C@Eb*&U2O_1H6eD0-OT#BpjrVn;FpYrTml/C@EeD0-OJQTV)@prcTZ`[K,SnEk6
+L8DPq\%\_FASq1fo)F4~>
+n,Fa5p"QFh[@`traL@e3ZH';S[(!TWaLfdI^Y-E=ji#0Zq8rU8b0'\_&H)"BX2hH5TrXQX][3\6
+p&=:W(s:5*s2rL_oY70F[@`trSY!75YeS6$b5_@]!WVQbs"XNJk.JCBW0XC$_n3Rh]YqR[Q`\33
+amAm&p>NEt]V_$rahl!:_S!h%UR/+$Y/KW%rVn;FpYrTu]V_$rUR/+$\$3Qb]"#5ZZ`^U/T!Z5F
+]X>\rai:`q]YsR2o)F4~>
+n,Fa6p>2t@eZ=UM@pjA5VU=eg_3:+KVj4$IC8Gcc]6/@Fk(*1&Kn]L*&Gtk;WTqTpK7&cli5)VS
+pAXCX(kn1Rs+Q1*oQm8#eZ=UMM6#1qC3kJbL&_%(!WUaKs"aTIi3L8Y]9%DS=%c@_8Qoq\Q,Mje
+^ZYCho%'Vpfs-K\AR&nkBNA5MIZhJ,\%Lhtrr2p5rqGBY`8J7hI"Ig.lAAo;Vj*CN`5KOlmf;eT
+l2^#Gi!/K*H[+r+rq$/?~>
+n,Fa6p>2t<kMOn;\['N3hWF4X[Y0BiTST51=J]5-]45Gek&9tjF*%<[&Gtk;U?psreC*(0l*mkR
+pAXCX(it?0s)W8[oOsubkMOn;fAGcW=D2YpF8u,Y!WUOEs"aTIi3KuZiS)`&P%K)R?_5HigZ.Ur
+^ZYCho%'Vikht+?^ST&uacVt6db<^GYIrulrr2p5rqGBY]BS;.da[(5m!MKmTSA/t]XtcSli$/M
+li$&Pm+H,cmEGS$s*t~>
+n,Fa6p>2sr[@`tra2YT\S?g2ZaLf*uZ+d9/YGJP3]=P\kk/R,lb0'\_&Gtk;Zc&u4UT9cZ]Z%)3
+pAXCX(s:5*s2rL_oY7-E[@`trSY!75YeS6$b5_@]!WVQbs"aTIi3L85VO+@*_S!Xr]YhU`Q)hd0
+^ZYCho%'V[\"T:raMc6.b/2'9W0XBs]tEJ%rr2p5rqGBY_n;k5X.u#``3Q/5Z+[ch`5BIkbQ,fb
+_uR[Q]EZ=!\@q:orq$/?~>
+n,F"!puK'(i4G(uBjP1gLSi>Li;Dj?mJZJ]_8V[aD81>TmXp2lrr3Q+m)Z*iad[p1OLjAdZJbKV
+lMhZas8Re,rUbE1n("LrFc!0LmqR0#KSBI'K`V5)r;SPNo@Tqufs-K\AQW2H>YA+2I#tqt_mA:p
+q!6%omEM>YEF3C,M0ru;BRGoQi5;n[p\t0l&,u=]ZGYV4OF1tuS&ssamJcANjSn*:eH""raT09X
+]*?C5d;e*jrU^&>~>
+n,F"!puK&rl/C@Eb,_hnf&#NPl29lJmJZ>Y[_7E.>ean1mW!:Hrr3Q+m)YjdjP885g>V;+ZJbKV
+lMhZQs8R.]rUactlf[0Wce%(;lW@h>F*%BYErl<fr;SPNo(a)Tqnkht+?^R1k-V.Yq4db<[E]<gGh
+q!6%kmH*0Sc)f%8f@%d'ajSo%l+=:\p\t0l&,u=]ZFfA[g="3pguRhfmJcGPlMg&Ik5aZDj8e6=
+i<JB,aC!lIrU^&>~>
+n,F"!puK'/]V_$rai29/T:E-p]_o\Ja8O3iaMkj"ZbO35m`<NLrr3Q+m)ZHMXd>f`R&7O8ZJbKV
+lMh[Is8U6arUdk!bdF(5[%3erbcnk&b0'b]aoVP0r;SPNo@Tq`\"T:raMYs:`4Wt0X-fcs_R&1o
+q!6&#a0;#+]#DgmSZBoMb,^o,]Y_#6p\t0l&,u=]ZGX>PQ`IiqQ`\3Ma8X!W^](nF[/dN3XT5F#
+V?X06bdQHlrU^&>~>
+mf*jpm*(7Pc(Ti:EGB$*LS:ubr5er`rRLr+*U<(NY'IS+IY.Irs8Vr]`i&+DRtH*M]&:E3iV3?6
+rtC+bo[oo,eZ=UMM6#1qC3kJbL&_()s8N)Mr;SPLn'@TndAD\?@9dDeDd61NGDi`Zi25/to]!Ek
+jM6t.CN"T^X,q^BA9Ws:g#/jap&4mi&,u:[YJ];1OF1b\Jt'm4c2Pfb_#CtFX8o-sRfJ`PO9VB&
+m>BH;r:Br=~>
+mf*jpm*'_Ajk\J7c-*iHf%o9Cr8[k>rTF4Fs6L]XVJ3ThCiK:Ns8Vr]`h;\Zgsjd+iT[kZiV3?6
+rtBJPo[oo(kMOn;fAGcW=D2YpF8u/Zs8N)Gr;SPLn'@Kik2+\7Z_bUdbb]s+d+I:?fr!Emo]!Eb
+lJgOHbKSDghqHN$^<kNjkh2rip&4mi&,u:[YI`uWg="-feD0-Jjo4<@ir7p9hZ2O4g]6+-g'6Bp
+m<[=%r:Br=~>
+mf*jpm**&]YaV8g]>hq$Ssl@Mr2ft'rO)[<*Q6+E[^EZo_oMZRs8Vr]`j!C`Q_UUKVS'pUiV3?6
+rtEQRo[on^[@`trSY!75YeS6$b5_C^s8N)dr;SPLn'@cOZCIMq`l-!+^Vmq/Z(%GrbGNq_o]!Ep
+^SmHs`P8I(a)SsZS$aK_5.\'1i+p&4mi&,u:[YJRrLQ`J6BUR/*jYl:a)W;`[nT)bD\QN3<LQNin_
+a1Ts_r:Br=~>
+mf*jso\XW*i4kqFKmn5cF+oR7r0m\[rN-%2*Qc^^kO,mVFF<TSrr2c[`i&+DRtH*M]&:E3iV3?6
+rtL1co[oo,eZ=UMM6#1qC3kJbL&_2OL&_/Qf)>V)rqYfrV<Z0lK5Y",H&7,k>[VW.VU=h'cg:)O
+VVp.4N-K8gOLhF&OF1bbM6#1qT(a)EH0rr3N.p"ZS*fs-K\AR'/*S#i=_RfJZOOT((:L]2o+JGsp$
+JssdGQdEnQoDa=~>
+mf*jso\X#cl/LOPe^DghcILS$r7h;.rSRY6*TZAHlg1mP@qtN0rr2c[`h;\Zgsjd+iT[kZiV3?6
+rtKPQo[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/Eu#rqYfrT'YOneBFf.dFZmlV6S=shWF0ocg:)O
+VV11kf[.jjg>T*kg="-ifAGcWT(a)EH0rr3N.p"ZS#kht+?^ST0(gu$reh#5t+f)XD$e,[tsdKe:W
+jQq`M`;K6,J,~>
+mf*gro\[+"]Vq9eTr>6.\"T;gQN3KQTDtc/Xg5FQb.ja`_=7=#rqbs#Yf*Z1UT9cZ]Z.>;p\s=T
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVn\Qq<>f"`3#B$^;\3sSYNp;`jhY2ZH8iem-`K&
+bdX:8Z+m?,VQH__X3.f?T!ce7eFNP:rt#,%goAT-Tpr=.`4i"5T:5bG!1*VNrgWt[rhBIiri6:!
+Q`\3@d,Foos*t~>
+mf*aqqX/WG_W8tMTTY4eK)U/qK)gW(M>rYXS#3I/dH'5?Eng'ZrVGj"Vs;BnK7&cli5)eZp\s=T
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVn\Qp>NEti4G(uC2\BXUmcmR>]54_aQfS<jQ=OV
+mEM>YEI<kZi.J;HOF2&%TZuktbjPB-rt#)$g8=>hXGM(0;-\$lM1tq]!.Oops)n<g!.b'#reUiJ
+c0C\FbP^u3J,~>
+mf*aqqX/!#\*E)6h:gN3eGdnoe,\%tfDjPFgtpuLk3CWD@,(/HrVGj"T^:apeC*(0l+"+Zp\s=T
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVn\Qp>NEll/C@EbKSAebhU^lV9IHEjQrJTjQ=OQ
+mH*0Sc-k>)l$'>ig="6rh<"$pbjPB-rt#)$g8=3!hq-2bI\k9<f@BlM!7Uqqs3L\m!7UqsrmqA0
+jm7iQ`Vf?-J,~>
+mf*aqqX2)'ahP'TR[0G:U].=lUB%"dSGnipS>!!h^Wa6tg[G";qWl/*`3#B$X-fcs`jF_!roX4p
+b5LtbU<L$;S@"iY[EPkia3)R)s8C+?rrDHbs"jZJiO-S9VO+@'^TNurQ_V:5^S@-t`3-u<k/aLA
+YaV8sX-fcsWO/OhX1P'oYfEcfmed"`&,l1TVTcH?S@$>O`4i":U&LeeW;`jt[/R*+VZ*@iSHbFb
+`4sd\r:Br=~>
+mJd^qpj[O*\aA4t^TjH#OH>CuM#`>1K)U-<K85DNVSLmPQ+GfBqYBHsVWu9mK7&cli5)e[p\s=T
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVo=bo%0_rfs-K\Dg@AOR%p.&DeON[]&:N6g"NpF
+jM6t.I#tqtnQ!<]]9%DlR`Oci_Wgprs8W&ifq\#dXGM(0;-\$^H2`3jJcLN(M>iS:Q2[6OWs60&
+oPWI0rU^&>~>
+mJd^qphaVJZ0gc:io&YJg=k3Wf)XD$eGdl:eCN:,hW!bdLUu=4qYBHsT^:apeC*(0l+"+[p\s=T
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=bo%0_kkht+?bgG,&R&f#lbfS;eiT\"^g"Np=
+lJgOHdb<[El9quCiS)`0guRgm_Wgprs8W&ifq[lrhq-2bI\k97dJhSne,\%ufDaJ(g]$"-hZi',
+lWi5drU^&>~>
+mJd^qpr'kP^;mghW1fZHR$aB(a)SH,;]U].;7URms?S>`p;]t3%jqYBHsYJdQ0UT9cZ]Z.><p\s=T
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVo=bo%0_]\"T:r^TO!"V5]fV^<3LDVS'gRg"NpK
+^SmHsX-fcse=4FiVO+?YQ`\3._Wgprs8W&ifqZd!T:E:/^VmmoY5YL$UB%"eSc4uVQ2[-LSd)(4
+gp>etrU^&>~>
+m/IRoK7A0UL=#>Kg!.UL]!;16!2faa+HVV=HujO_LQf!flD_V\p%[glVWu9mK7&cli5)e[p\s=T
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)MrVo=`mE;6kc(Ti2H&f>hKr2t]Jo>jkZ.\'2bfcd>
+fs-K\JssdG_-N&cad[p1OLjAg\E!A`s8W&ifV7ibXGM(0>]54NNrG.>RK0#[X8][1`;[jWeHXt!
+QZ_N>rq$/?~>
+m/IRoEG]?tGK9+9kiLmaiSaXk!8d_1+PPN"da$4gf%T'Dm%_DXp%[glT^:apeC*(0l+"+[p\s=T
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)GrVo=`mE;'fjk\J3dFmLBHCj3QeBH:li98jibfcd7
+kht+?eD0-O\4hD=jP885g>V;/\E!A`s8W&ifV7]phq-2bV9IH@g&B_)g]610hu;R7j8S-=k6C2<
+M.>bmrq$/?~>
+m/IRoaMbg%\]`%.\$3!3VP3pZ!1a%T+IJRhX1,@1SsH(S`3R5?p%[glYJdQ0UT9cZ]Z.><p\s=T
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drVo=`mE;NMYaV8sY*l&rV6m@kUV="&Tsr7Abfcd*
+\"T:rUR/+$_kXWXXd>f`R&7O6\E!A`s8W&ifV6TtT:E:/`4r(<RJrTQQN3KRT)PSeX8]7#[0F:a
+^UiXmrq$/?~>
+li.EIK7Mg$DMG[ZmHWWfg&0A#dJh30]!eJtHt[A<IZ1/OhPJTcp$'GllH,NJI#tqt_6r:sroX4p
+L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOrrCXLs$m"_jh7eZ`0GjuNjdd5>E%jhRtGd;VU=h"]==F!
+c(Ti2JssdGS7RiJad[p.NjdcjXPNRJs8W&ifV.caXGM(0Dh=FY[f3l;a8jKaec+J,kPjcGmfg[e
+F+!T/o)F4~>
+li.E8EGjWC>^*F*mHj*%kksTDk5OHAi?$k0d`TeZe(EO>g8!$]p$'Gfm,ZsOdb<[E\@(>jroX4p
+F8ba`U?h""f?`(+kNc5`E-$+#s8@$=rrCFFs$cq^jh7MVj4i&1g#;/[97H6ggsjX#hWF0k]==6q
+jk\J3eD0-OQ;`J'jP884g#;/:XPNRJs8W&ifV.Wohq-2bbgbG*rSdb:!9O4CrojFKrp9XM"hf1j
+C@faAs*t~>
+li.F:aMm#I[(3loa2GX'\,<W6ZMpsKVPBZKX3/;gW10<_`i@DPp$'H!`3#B$X-fcs`jOh#roX4p
+b5LtbU<L$;S@"iY[EPkia3)R)s8C+?rrDHcs$m"_jh8(=X-KNaRA7@AR'af6Q_V'_S?g8/]==]X
+YaV8sUR/+$V5h,FXd>fcRA7@7XPNRJs8W&ifV-NsT:E:/^S@-eU]..iXT5U)[Jmf=_Z%LQbQYtt
+\\[n'o)F4~>
+li7!=$\\/%HZm!"Um/^2i;E$Dmf)Joi8)elOF1bNCOVG]jLD\VnE7]clH,NJI#tqt_RAM"roX4p
+L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOrrCXLs$ltZgo\u[[Z5ZaQ,Mk5ARFoVXGM(OR`OceV4b6W
+^ls4rP/$)KPAFh!eZ=UMM6#1qT[iW2s8W&heXl6[XGM(<Jssd2h>Z@3l2^5Nmgm:N_4m0YQCDZ,
+]Q\dTqpk9;J,~>
+li7!+$ZblVBk=lTT8'h`g&117llbQVk2G%Bb-T:>g>_D%\)6]<_k-5Ugsjd+iT[k\j7rW9rtKPQ
+o[oo(kMOn;fAGcW=D2YpF8u:=F8u7?d/O&7rUemIb3@m<dF6k1lc3"#lf[0Wcd^b2m$X]CXm4p"
+e'ct0lKXR:;sWW(f?`(+kNeeko)/OfrU\R2lf[0WccjnojQGb+l2L#LmJcD^]!o/6KnbAP=^8UN
+CN'*ro)F4~>
+li7"-$H_qY^q@7XXh;`qqof&^rkoql]!A3#X3/H$W0XBs]slngkJOI@Xd>f`R&7O9[c@/^k5Q.<
+rUea:bdF(5[%3erbcnk&b0'barQ>0?!:Bdc7fDu7Xi\/LRBEEPX2<2WV9H?>S(a)#&XXi.38TY%t;
+QDgaJW5$rJZ)Z$UT:E9ZT!ce8eaiY<s8DQ>T$4U7S@$&+Q`[[,rk/6K!6>)_&&H?.^q7:oS$963
+]Y_\cmIL:-~>
+li6s<2#W&YJE5FsFE)5@ChmdZBqD8fTu#(Ci4G(uBjc";VU=h+cfjE(U?]jiK7K6*kJXplq#9FU
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8N)Mrr6C(n'RfrdAD\?KqQ]XTl+Jgh6r>iI#tqt_23g5
+eZ=UMKqQ]X\#XO`i7YAoG_Mg8m@_Yiqu?]on^<lpeZ=UMJssdGn'Ake_3:+KUM4MBY&A<#FEMfU
+H@4h)JqX-So)F4~>
+li6s*2#VE5DWKN]@UNJQ>$4t$=.>q=S%$E(l/C@Eb-B7ChWF0tcfjE(SF#=leC314laaReq#9FU
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8N)Grr6C(n'R]mk2+\7e_T?SP[7>0l/C=Cdb<[E\VYt)
+kMOn;e_T?SYH)&5g$%AHd+-t6m@2;dqu?]on^<llkMOn;eD0-Olc-NF[tTQlSl]'nY$PID@Uiut
+BPQXHEH;'*o)F4~>
+li6t,2#YM9`T5ar\[SrOZ*:I+Y+i57WlW?)]V_$rai:i_S?g88cfjE(X2M-,USa<W_TKFMq#9FU
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8N)drr6C(n'RuSZCIMqTpi4+^oONY\tb[rX-fcs^km]f
+[@`trTpi4+^8n`HbI=17Z([Vja/I2Kqu?]on^<lM[@`trUR/+$bf[cCaLf*uX0/\*Y-k^J\[oH%
+^VT$NaN=GKo)F4~>
+li6s<2#i8_K_Y2kIsud#H[:"iH-j`V^2IeN^Yl_cHtd>EP/$(g^YmtZ`Se@iI"Ig.lD;5Xq>TOV
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8QW\s8W)ol,0@_ad[p&KqQ]XKQ_1:jM6t.GDi`ZheJ;=
+ad[p&KqQ]XT"oMd_r/.gI"7L#kH2M^q>UEkm`hftad[p7R`OcP@;2l`EH?5FcZsikhL'a#It3(>
+JqEcNKSBHWo)F4~>
+li6s*2#hW<Eqo:UD/=!3BkV23B@+h3^0Xs)[HZZ(d`Tb]g>_D'^YmtZ^$4M0da[(5m$YTNq>TOV
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8QWVs8W)ol,0+ZjP880e_T?SFCn^QlJgOHd+I:?fP6?2
+jP880e_T?SR_WK>]BS;.daQt2l_VAZq>UEkm`hQojP887guRgM:fsl,?t!PUcY$qGhJ6nCD/O:^
+E,kYnF*%B.o)F4~>
+li6t,+TKU,anYMj`5BI1^q[Y9^<k'7^9t24a1S:9X3&A[QDjet&E)EU`Or(7X.u#``4itKq>TOV
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8QWss8W)ol,0^CXd>fpTpi4+[^36X^SmHsZ(%Grb%dEa
+Xd>fpTpi4+VnfsO_n;k5X/;/__R@5Bq>UEkm`i,WXd>fXQ`\34Vm!82\%'#]cb(a)0KhSR.I`5Tad
+a2n%tb0'bOo)F4~>
+li6s<!<<%P#6+S\KS+o=rdlKhJai)WkBqQiBY`Q<OF1bfNjdckYLhI8`8J7hI"Ig.lB]<OqYoXW
+'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8Q*Ms8W)li3UA[]9%DfOLjB?BmjudlH,NJEJ:(1m;TS[
+TnRK8P/$):VU9^0\E(GhIXI6gi5;kXpAP!fm)c3kad[p7R`OcUD0FZ^IXZcsn:?2apAT^DKEM.*
+L&V(*!WUaAs*t~>
+li6s*!<<%>#6+SXEcH)Lrbs4VDt*13kA"YE<jq8Og="-kg#;/:YLhI8]]nD/da[(5m"rUDqYoXW
+'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=s8Q*Gs8W)li3U&[iS)`.g>V;]=)D<!m,ZsOc.1Y3m;0/k
+h:9cug>_DNVU9'aYj16%e'ct/l+=7YpAP!fm)c!gjP887guRgR>@lQ)Ci+$,n8E:=pAT(2EWc5\
+F8l/[!WUO;s*t~>
+li6t,!<<&@#6+SkaiMQJrl6AX`piE7kJ=mIY/e2PQ`J62RA7@8YLhI8`4Vt6X.u#``4<bLqYoXW
+'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?s8Q*ds8W)li3U>6VO+?aR&7OGY.D'T`3#B$]:k[ta*G"q
+R\@<kQDhRHVU</e]t^M3W2l;_]Y^u3pAP!fm)cNNXd>fXQ`\39ZFnr/_o0L4nA`NApAW/4aTMI`
+b5VC_!WVQXs*t~>
+li6s<!<<%Ps8N)[re2ebKnY3YK`(_#q1=1VF(X=_Z&EpMM6#1qU!D2o`8J7hI"Ig.lBfKTqW7_k
+L&LYrU@6X6M04ZUeaI7!JqSjXs8@ZOs&IYMs8;H=U[Qa7M04?6`95!TJotereZ=UMEJ:(1T$<s_
+EH?o4dI+ERhL0LDlH,NJFc!0Ln"\J)r;QQYa/A4ERtH<]aQet0II`$cq>,dBKS9@(qh51QKn]P\
+rr2uLo)F4~>
+li6s*!<<%>s8N)Wrc8'lrc9CaF8YoUq/L?3@T;"Di7QE&fAGcWU!D2o]BS;.da[(5m#&dIqW7_k
+F8ba`U?h""f?`(+kNc5`E-$+#s8(a)$=s&IGGs8;H=U[.+#f?_q#j6O-YEb&8;kMOn;c.1Y3RH<8T
+c-Fnsk3T+ZhJ6Snm,ZsOce%(;l_E&%r;QQYa.Ve[gsjj/jQqS/C[uK?q>,.0F*%?[qf;o?F*%A&
+rr2uFo)F4~>
+li6t,!<<&(a)s8N)jrlP5frlQPcb5D.Yq8gS7\Z<r`Tpr<oSY!75U!D2o_n;k5X.u#``4<kPqW7_k
+b5LtbU<L$;S@"iY[EPkia3)R)s8C+?s&JIds8;H=UWg-<S@#/YX2<&d^UpYm[@`tr]:k[tT<OcX
+]""B&ZH:.uhSQh-`3#B$[%3erbbNb[r;QQYa0<LaQ_U=BXi.i]_XbeCq>/52b0'__qoT'Ab0'b,
+rr2uco)F4~>
+n,ELhr;-6gKE2#NL&_/QjSji5PQ$7^s+ULQL&Zj[nTo&VjM6t.EJ:(1mA%_LYf,J3OF2YKaQf/4
+lh]`C'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Or;T@cm)ksfc(Ti2KqQ]XUN2*7D9q%HNd>>XKqZbb
+KlLLALSiJeHctZ'GFn6MVMB5HTZuktbjG<,qWl/!lH,NJJssdGPf8.JL&V)UL&Zj\s8VtM!rmt.
+r;QcJo)F4~>
+n,EXlr;-50Ec_6ZF8u7?i;RctKDop<s)\5?F8p<%nRu.&lJgOHc.1Y3m@VGHYe0/Yg="L+jQqfE
+lh]`C'Qa6FfV7]phq-3+hrj<-BQ/$6s8W%=r;T@cm)kgbjk\J3e_T?SQ=+lK>KH'fg!Rd`e_T?C
+e]kAEf&#QUD9M0\AXi&KhU^!&h<"$objG<,qWl.om,ZsOeD0-OL;e$*F8l1CF8p<&s8Vt;!rm=_
+r;QcDo)F4~>
+n,EXlr;-62aiaV^b5_JAoDZl4d/M06s2tBAb5]W+n\;BI^SmHs]:k[ta/m>/Yf",NQ`HmJXi.fj
+lh]`C'[$CHfV6TtT:E9ZT!ceH^W4L>s8W&?r;T@cm)l9IYaV8sTpi4+_RIFsZHKhSRBFZDTpi3S
+Tt87RT:E4/Z-2CM]VEWTS=[3`R]si3bjG<,qWl/*`3#B$UR/+$]Z%hbb5VDEb5]W,s8Vu=!rpEc
+r;Qcao)F4~>
+nc'.!r:faIk^J&6q1OHUs8V0ZK`I>9KdHbQs8RfQKn]8LEKTP.RtGX2R`Ocm_U#F'i4G(uJssdG
+R)nXjjo6$KrUea:n("LrFc!0LmqR0#KSBI+rIt4M9)eVI]Xd+=PC@M*TZukXG)CZeZK/fbIVW80
+KqX3??Yk7X`95Tkg@9`?VXN':M04?6`948;kP>)Qlc,jfad[p7R`OcY`ddi=rr3.Us+Q1,s8.KO
+s+Q1)rrCX@s*t~>
+nc&ppr:faIk\Y3Vq>PI8rrD!VEr^jlF!^j-s8R0?F*%(k?\Ie,gsjQtguRgr_U#Etl/C@EeD0-O
+Mob8]jo6$9rUea:lf[0Wce%(;lW@h>F*%B]rH%r;9)eVI]Wg\\g=+<sh<"$IA9r$!VX!0pe'"i;
+e_Sd#XNT)Ij6Oiug@9)pVX*F&f?_q#j6NPVkP>)Qlc,UajP887guRgV`bkQnrr3.Cs)W8]s8-j=
+s)W8ZrrCF:s*t~>
+nc&ppr:faIketH\q>SP:rrDZiaoKffasI)1s8U7Ab0'Iq[^sDZQ_V9iQ`\32_U#F']V_$rUR/+$
+]#a77jo6%;rUea:bdF(5[%3erbcnk&b0'barQ>*=9)eVI]Y;.ZQDhEhR]siB]>qdt`kSI<W5Z`f
+Tph[d`PSL;X2</eg@<1tVTcH?S@#/YX2;<[kP>)Qlc-0IXd>fXQ`\3=`l._rrr3/Es2rLas80q?
+s2rL^rrDHWs*t~>
+nc'-soB+WF^iO[Fl@O\Cs8V0ZK`I>9KdHbQs8RfQKnT/JE09G-RtGX2R`Ock^s/sui4G(uKqQ]X
+R*+gnjSonlo[oo,eZ=UMM6#1qU=b'NL&_2OL&M$DrUo!KdG;6kH@1gci:1T.N.5u(mEM>YEF3$l
+KlLI-F,-X?m]V!!p@Wg>`8J7hI!h$ei5;eUp&+[P`hr%CRtH<]aQf#0J,4lurrn,VKn]R,qh5+O
+Kn]I)!7p`@J,~>
+nc'-soB+WF^gUbfl>^ics8V$VEr^jlF!^j-s8R0?F*%%j?\@_+gsjQtguRgp^s/sll/C@Ee_T?S
+N6:PbjSonlo[oo(kMOn;fAGcWU=aF+F8u:=F8c,2rUo!Kb3@m<dF-b-l0;DaI;NM<mH*0Sc)e"k
+e]k2#cIUk7m&+X\p@W1,]BS;.daHk.l+=1Vp&+[P`h;\Zgsjj/jQqW@D>J>QrrmKDF*%B]qf;i=
+F*%9Z!7:<:J,~>
+nc'-soB+WF^pq"llH%)is8V]iaoKffasI)1s8U7Ab0'Fp[^j>YQ_V9iQ`\31^s/st]V_$rTpi4+
+]ZTX=jSonlo[on^[@`trSY!75U=dN/b5_M?b5M?4rUo!Kah"78Y,dqe][X1"b/Cp%a0;#+]#DY"
+Tt84_\=]:sagnqCp@Z8._n;k5X/hVb]Y^o0p&+[P`im=_Q_U=BXi.ll`;7XUrrpRFb0'baqoT!?
+b0'Y^!:B@WJ,~>
+nc'-kiPqq)a2=clc$k7ts8V0ZK`I>9KdHbQs8RfQL&18gCp<!9PC@G%R`Ocl^rr^oi4G(uKqQ]X
+MU(\gjSoeio[oo,eZ=UMM6#1qU=b(rrr<"P!WRlPs%<4Ze"6$YXGM(MQ,Mk&Dg[UsH#)m!XGM(0
+;-n6L:1/-uVU=h(JaWC0I_`,L`0GjqM6#1qT[`N/qWl/!lH,NJJssdGPfA4LL&V)UL&Zj\s8VtM
+!rmt.r;QcJo)F4~>
+nc'-kiPqjt^:9S9c"q??s8V$VEr^jlF!^j-s8R0?F8G@U>,:HCg=+9qguRgq^rr^gl/C@Ee_T?S
+IEq<ZjSoeio[oo(kMOn;fAGcWU=aG`rr<">!WR6>s%<4Ze"5mghq-3'gZ.V.?#"k-B3FQ`hq-2b
+I]UeqFg96ChWF0pEUN\uCquq6j4i&/fAGcWT[`N/qWl.om,ZsOeD0-OL;n*,F8l1CF8p<&s8Vt;
+!rm=_r;QcDo)F4~>
+nc'-kiPr.7`lc6+c,7TEs8V]iaoKffasI)1s8U7Ab51SWZ,=>TQDhQnQ`\31^rr^o]V_$rTpi4+
+\'FI?jSoeio[on^[@`trSY!75U=dNbrr<#@!WU=@s%<4Ze"4dkT:E9cQ)hdF[)'u+^9GhhT:E:/
+^W!e'^;d[TS?g83^(a)(jm_n`auX-KNgSY!75T[`N/qWl/*`3#B$UR/+$]Z.ndb5VDEb5]W,s8Vu=
+!rpEcr;Qcao)F4~>
+nc'-^a04poi8EeVW-3ZCrVtsXK`I>9KdHbQs8RfNKC@U-F5>6@LN@BcR`Oco`65"GeZ=UMM6#1q
+DU\.Rp&><sr;6?dqYU6jq>V90o[oo,eZ=UMM6#1qU"4elrVc_LL&Qf)s%<.Ra/A4ERtGX5TZul!
+F+3lVHuHjZ]9%DS=&!$r>&8_S`95UOL@kE@JBOYRc(Ti2JssdGW6"<#q<Q%ulH,NJJssdGPfA4L
+L&V)UL&Zj\s8VtM!rmt.r;QcJo)F4~>
+nc'-^a/J(a)jl07NeV.FL`rVtgTEr^jlF!^j-s8R0<EUV\pA(g#$f$;LhguRgt`65"CkMOn;fAGcW
+?ISHBp&><sr;6?dqYU6jq>V90o[oo(kMOn;fAGcWU"4/ZrVc_:F8g7Zs%<.Ra._k\gsjQuh<"$i
+@;P]2C0e=5iS)`&P&IF@T$,U;j6OjiG4b_0DTeR;jk\J3eD0-OU<)Zrq<Q%nm,ZsOeD0-OL;n*,
+F8l1CF8p<&s8Vt;!rm=_r;QcDo)F4~>
+nc'-^a10:/]Y),+XLuKmrVuKgaoKffasI)1s8U7>aR@orYf<u=T!uJ0Q`\35`65"$[@`trSY!75
+X4-V:p&><sr;6?dqYU6jq>V90o[on^[@`trSY!75U"76\rVc`<b5TQ^s%<.Ra0ERbQ_V9gR]siL
+\AS(6_6h:rVO+@*_S*q&_nr:9X2</a_t<m(`QP7$YaV8sUR/+$Z,l8,q<Q&)`3#B$UR/+$]Z.nd
+b5VDEb5]W,s8Vu=!rpEcr;Qcao)F4~>
+nc'9SXPhXI]=Z#7iG<diqYoQ0L&[A9KdHbQrqqE>IaturhU/3UF(T]X[b^G5bKQ^LeZ=UMM6#1q
+E7a^[q>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X9#eZ=UMM6#1qS'QTTo^qg.K(aiorVlfkjh&%`
+^ls4eKqQ]XKm&"Cq0mFMlH,NJDd5q0:1/-uVU=h8^P_gcr.3Fnn("LrFafLgjL;_]p\F-qVs;Bn
+K7]Q5lBK;<qM"qK"blu1L&_2MK`_:.L&CrNf(/ik~>
+nc'9SWnHRqiSih\fii$+qYoDoF8pmlF!^j-rqpd,Ct6(]g#h/BcG\,`iTTQ_bKQ^HkMOn;fAGcW
+@+Y#Kq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8tkMOn;fAGcWS'PsBo^qfqE;";KrVlfkjh%_]
+inDl+e_T?SG%>Leq/'Sqm,ZsObbf&mFg96ChWF1&^O#\Sr,:/\lf[0WcdLP,lE@e[p\F-qT^:ap
+eC<:7m"WMsqK)Z9"`s]bF8u:;EruA_F8Z%<d.73e~>
+nc'9SZH9MTVP^E'bd+t%qYp*/b5]ifasI)1rqsk._pu;gaKh>-\&ke@UUnmMbKQ^)[@`trSY!75
+Xk31Cq>V!)rVQEao'PZ(l0e6@rVuorrb)3,n^X8U[@`trSY!75S'T%Do^qgsa7dUOrVlfkjh&4@
+W0XBoTpi4+\@]`Vq8BhV`3#B$^;[e"^;d[TS?g8I^W6-Kr5R<^bdF(5[&B:h^V%/=p\F-qZ,Ec2
+USF0X`4X+.qTAg;"j6kfb5_M=ao_Ucb5D8>mIL:-~>
+nc*OK[-uPGOH>aGkFupAn+bmrL&R9iKnT>Up@*O`FJtS`dAD\?@;LIZ`95R;eBafVeZ=UMM6#1q
+ES:!_s8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQg`J+M04ZUeaJ@(GLtL"fm7s@hL4ea
+qu$0FYL217Nd?)7]&<*nH%GnjJ9ZA-dAD\?@8BKj?uq+#dI*XPNVi_RK&3]Ii4G(uH&f>hd&Ypm
+q!?,$lH,NJJssdGPf/(JL&V)UL&Zj\s8VtM!rmt.r;QcJo)F4~>
+nc'9DXR#',g=k<Al]tjkn+ba\F8ggkF&i*Wp@)nN@]5OEk2+\7ZcghPj6OdNeBafRkMOn;fAGcW
+@bLDPs8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQg<hlf?`(+kNdu6A_5Se;qYhuhJ;NO
+qu$0FYKH+gg!S7%iT]W0B5d_FDe<\Lk2+\7ZZeTUZ-LqWk3SV`IJa$BESdn-l/C@EdFmLBafF1f
+q!?+sm,ZsOeD0-OKu@j)F8l1CF8p<&s8Vt;!rm=_r;QcDo)F4~>
+nc'9D^Wa*WQ^<u<_SNXqn+cFqb5Tceb#S>[p@,uP\Yu4BZCIMq`knU<X2<8heBaf3[@`trSY!75
+YM&RHs8W)trVZNep@@V6hpffb^;J=Un+chXq=jUUo^V+fQcuk0S@"iY[EOK:][tfg;q\q$hSS[Q
+qu$0FYK=ANRBETXVS(E^^;g*J`kAb%ZCIMq`kJmq`jhY2ZH8leb5;2:aPO,A]V_$rY*l&raK+(e
+q!?,-`3#B$UR/+$]>VYab5VDEb5]W,s8Vu=!rpEcr;Qcao)F4~>
+nc'9;b4!l]M0t)UdGB"cfBCk=p@j[JJoL1-hpQSFL!f;8VMB5$?uLXcaQfS"h9hk`eZ=UMOLjB?
+F4p-[qYBp[oC)#,hUTfaYbA&-`lG$ifB`%tki(=Mf[S$HJa_-jM04ZUeaI.-BVD/pUMFYIER*V8
+q"!(5n("LrFaT:^i4s2VK)PX-JpVC^h6r>iB2q?'Ck.ehkL-KfO8]+XKB9bOjM6t.F,-X?m\%qq
+p[6;,lH,NJJssdGP.uJ@K`:rSL&Qd[rr)_I"T*k*rVlfr!7p`@J,~>
+nc*F?_!C1@f@&7,k1O9PfBC_'p@j)WE,b8_hpPr4Fis+6hU]uYZ-:_QjQr5-h9hk\kMOn;g>V;]
+A(gGKqYBp[oC)#,hUTfaYb@es]t^>SfB`%tki(=Mf[S$HJa;LVf?`(+kNcc;<hZ7^;kmK!X^KH7
+o(_e.V!I4$f?_n!iT[dUBlO%LE+rRtl/C=C`JdH]bL>5+lc?3`J,TEHETOj1lJgOHcIUk7m%)Ml
+p[6;%m,ZsOeD0-OKthI!F8l.BF8g6%rr)e:s)J8>EcV-Xrr2uFo)F4~>
+nc*F?cciegSZABQZH'5YfBDD<p@lhQa2dYehpT$6\&l[rS=[40`kS:8Xi/)kh9hk=[@`trR&7OG
+YhAUCqYBp[oC)#,hUTfaYbAD=`Q,6qfB`%tki(=Mf[S$HJ]tNoS@"iY[EN9?Y+_Sa;kpS%XgcU9
+o(_e.Us-6=S@#>aVS'sU^rQEPa2#%)\tb[rahbO*_PWU!_U,F?bl.S@aQ:(S^SmHs\=]:sae[;P
+p[6;5`3#B$UR/+$]>)8Yb5VADb5TQ+rr)f<s2bE@aiXM\rr2uco)F4~>
+nc*47am[c\M03lpVU=7AX2DYthr*F?He$BWZ(@3,mG6$aLN?m+F+Tk%lJl]gjO'LdeZ=UTOLjAd
+Ems7=lK@0_f?_FIY+_Mj_scmOi8F"D[FF'`_m?><U7RUANp=`UK5YmhX4?t5=OF+bi:--\TC1+(
+LNA'9aQgZ_I=qOuK77j9kJWX9D-KS>F,-X?m\IV[OT,:[K^6^ElH,NJDh=G!lD2;\p@-Ohn("Lr
+IZhJ,YdAcGK(o!4K(X_Io^r*6$A!`qJ:[ChrVliJo)F4~>
+nc*47_!C1@f?_anhWEL#X2DM_hr*F-C":JEZ(?]lmHN`hf$:UhcICY1m+PXHjO'L`kMOn>g>V;,
+@ajQ-lK@0_f?_FIY+_>^]BehKl07TM[FF'`_m?><U7RU;M!X3XeBH7jhrjb"=NRAUi:--\SF#Cp
+f$;e#jQsB`CN9@QEGT'Llf6aKbb&=KcIUk7m$>EKJc>]LEpLf%m,ZsObgbG/m%2)Xp@-Oblf[0W
+db<^GV6jt*E;0)"E:n0ho^r*$s)/22DK#4DrVliDo)F4~>
+nc*47cciegS[>kuS?g5>X2E2thr*G/^t$]GZ(AVMa1ALFT!u_W\>,Cm`7D3;jO'LA[@`tiR&7O3
+YLD_%lK@0_f?_FIY+_f&_p$'6]Y);*[FF'`_m?><U7RUKQc-"mUV=++T!e:9=0]X#nEnSub-IP/
+\"f:l`6Ga-aSu1[_mmP"X-KNu`4X+"T:E4/_nY?Zrr<#?lc?cXXd>fsUR/+$Xhs;qnC+,U[@`tf
+QDhR:[(u.Np\+=$ouG,Fo_li1`X)"O`qB0+rr;BVs*t~>
+nc)Y-^$jLPM039KLSiJe[@<=qYHkHOCnR8m`:*!Ic*j=$F(&HcF+Tk%lBlY.kg#aedAD\HOLjAb
+CqIj4`P/a]U7J-idI6Jci75rb]=Z>NZ*V*B]]&eWs69m3RtGWa@WdO/pXLeMmB4Okk/aLdad[p$
+JssdGPB25+rr7Y%GB`K&VMB5$:LJ7!VU=gVcgHtqs!`WjdV81#XGM(IOLjAf[,CTIfTP^RXGM=d
+]&:>mFOtothV<G1H@"5rrd"rtG^%>TGi%`Xqu51;s*t~>
+nc)Y-[-Qo4f?^qOf&#QUXI"rNYHkH=>+h:S]BehJjl,%HcEjdccICY1m#,>akg#[ak2+\;g>V;*
+>eA/$`P/a]U77dYb3SH\l0%-eiSinaWjB@;[+YBCs6L$PgsjQF\BidapZF'kmAS+ek/a:`jP88/
+eD0-OKjnn=rr7"VAS1;khU]uYGHoHEhWF0;cgHDas!`!XdT>bthq-3&g>V;.[,CTIfSo.Zhq-<1
+iT[b>@b5APhV;huBP?&Nrb)[PAnB.sBAVqGqu4t5s*t~>
+nc)V,`lti^S[?GHT:E40\tl%*YHkI?ZCmnn_p$'1YbRYY\&QG.\>,Cm`4NS3kg#pFZCIMeR&7O2
+WOp<q`P/a]U8"j)aiqfB]X=l?VP^T7\[/rJ_>DIV`!EK3UV=^f[%3f_[4Ai/\&dXmaK`[cQ_V9i
+Q`\3<\\uSgs2i6mZc]SDT!u_R`jhY2ZH9H!ma(n4.EV)-Y0=;GS@#>aVS'gRi:QTmWQ_cBS?&$S
+]Z-GOf>6A$gq_UX^Y%3<^C.ch]Z[t%hWjb1rpB:VJ,~>
+nc'0HRIA\,M0398F,-X?jR)E^rkh(<i:$+!i75rXToOhJA861.LP`(^`-6OKlH?0lad[p1OLjA^
+?]1/JV6.\_n*]K%h:9cg]<%KcOH?p,d?'OMjOsI]s2bP9K5Y!k<+:!,pT,mRg#90eh7o`Mad[p$
+JssdGQ$.\2s8Rb(H>MNmZ&Ep=<,[AWaQh5lh=Qm0s!`WngMGg$Z&EpMM6#1qUt5&,hO2^G[Z5Zl
+Z.\#UAuBONY,Q33CMTZ=rb;gTBU>]aLpG1^o)&FWs*t~>
+nc)8.O6budf?^q3cIUk7lL!oX]">S_f^%njl0%-dh:^?(^<=gJf%8gB]k;&rlH>shjP885g>V;&
+:Q(I3T;B3Blg4!'l0%0giSWGig'?U#acM\=lKJ0/s5XI@eBFe;MR_!apYRL[kh32lh7oNIjP88/
+eD0-OLLb:Cs8R.ZBj03Ri7QDkMTjT*jQsunh=Q@!s!`$]gKN:oi7QE&fAGcWUt5&,hNQ%FiRuW2
+i98d6<2X!*Y,PR!=]qJnrE'D-LnfcOZHD.squ60dJ,~>
+nc)Y9[*5qLS[?GW\"B1r^W4R@_Sa:4bfn5J]X=l:R[KkYaMt`sT:MR]^pLo8lH?NPXd>f`R&7O.
+S;WW<YI29hbf[l=]!\cCVOs3@Q^=JYaH2S/^UO-Ks/cQnUV=^^_8ipRpR`t2\'2).h7p)1Xd>fs
+UR/+$]t;8*s8U6^^p;1nTpr=._7ub3Xi/Yoh=T(ns#A0ngTo&4Tpr<oSY!75Ut5&,hQY27URA9S
+Tsr3dXJ`D/Y,SY#YcsjrYct=7XhV3W]<]T<o)&FWs*t~>
+nc'0VN6pChNd>MP?uq+#^s1EcrSSpRe^;LNXIG6(H?!kGIYWcWX4>"cJq))3aJeCGRtGX,OLsHM
+n,MYikMY1HdE024XJ(o@M1^8)MlYCsFL1&DZ2C^'RfS.[raGtABP;P_M(>%9lEJOb\AdC<OF22-
+X4?ZQG_(PJs+Q)REO4`APC@:PDh=G!lBHDSq31gX,),dNE5LPFOF2&%TZuktbO"i\Tu,a"OF282
+Z.\U7d)!W:p$_nF#4:BQ_rC@fo)F4~>
+nc'-UK#m38g!S!WZHh%XioTA$kp,ETk2bLYgtC6*c-4M^f%8d9kI7I4D92%aU?psreBH@piT^@-
+s6LTgl07BnjPo.Uh:pZ8eC2juhrj<IX6S^&r87P0!S#?m\-'[kaj9_5/)94PWm0/*^$4M0da-P&
+kNc2]DfYmXF)bu&WTrKse'"T3eD0-OL19BBKDtlpF8+[#\EVu+d`p=ujmAV^m.98,\*;l*da6Y)
+kj.QV[^s'Cli-5TmFnMViq<9@s*t~>
+nc'0VZcp"URBFEJ`j_P0W3E\@rOaAa[Bcp3T9kt>Y.DBTW1TWNT!cJ9^r5@#aK`[cQ_V9qR&7Oq
+bl>Tu_S!IfZE:(#T:2%3S>3$`S"@%3FLf/bU&:P_QN<kqrl5,_b0%*cS1Br.`4=.E\Ac+XQ`IKa
+T!ceF]uJ1os2rF"[_okYQDhd@^S@-t`4WYEq9]-@,0KZ>[E#qWQ`I`lR]si4bO"i\\B2C\Q`IB\
+Tsr7iaN268p!!ER#04rt_rC@fo)F4~>
+nc'0cRtpCUVMftKDeO3IPG,(drOX;ZXJVJKM1^+oFaSdtP,>;-e\H%JMh9@BaJeCGRtGWmI#tu>
+ec3`.`4NIZVONd0M1pJ-Fa&4bMne?DB^aKQN;SP4K)foiFT?^[Hn9lHdI+0[e?m0P]9%DfOLjB?
+CjL\ds8RfLJ9?_9c(Ti2A:Tr`kMg9&nbeUMruZskl#`9Wad[p$J<e(9Xha,ll)U*7ad[p$GDrfW
+e_U5_p!s&`#0kigWQso-o)F4~>
+nc'-bOa-9ThUp<(bfS/]g>1Zai?R:<hV?i:eBuOedaZn&hV[JY\6I:+EQd[hU?psreBH(`g>W%o
+s5Y$WiSi\NgtLH5e^Msmd*gFrip,fBlf[0Xr7Ctu!6tJg!7CJf/C`P=m&8(V[(PY^g="F'iT]W2
+BlJ.ns)\$SA:3e+h:9cae(`pKfii%Yr.G"K*cq2B@Z'O5gsjQsgZ.Us^ut@SV2"?tgsjQpf\krU
+rTX"<ro=:Fkj>1kmJ?DRJ,~>
+nc'0c_RddlS=?C\^WO$WQC=G@rMCg5T:D77S>36u[&]smQCOPP[D]AsaN3T2aK`[cQ_V:;X-]^_
+[K!?GX/;YaS<oP0S=ud[['?[,S#F*RB[!lVS,AfVUB%q)ZiI9%X":$9ZH9W!e?m0,VO+?aR&7OG
+Z,"E&s8U7<`OiS!YaV8saJP6'_UPj)nbgc5ru]D[l++@CXd>fsVNn4![_V(ul,(-PXd>fsZ(%Gp
+[CZ@MosOe$#-bSWZ-Mb5o)F4~>
+nc'0mWH+9hdBSspJp_c`IYEW=rK&7_M2-_2FaSXiM3+1,^X:TgUi1MBOG)'LbGsjLRtGW]Bmc$A
+XT+b,Q&q#_LP(&%Fa8@dLP_+]X2!`#EpqP[M>_f(J:`B,rJ:N7oT1T#dI*ONf!WHS]9%DhP/$(r
+Dg[1ks8RfNJU2A*eZ=UMFb#q%lD8QNp\pBUruZslmWXTVc(Ti2I#tqt_m\Rsn$RH/dAD\?A9a'7
+XLA,?orS.^#GJT^e%=]9rq$/?~>
+nc'0mT4!H@k2>"HeC)^he(*('rRrLKf@JI"cdL7kf@o$;io]FXT3Z'nJ9&m$bG=LcgsjQ8b0o#C
+huDIKgY1?4f$r0rcdC1jf%8X2hr<ptEpMoGfDX,"e'umtrRV&&o\(hPk3SD[f!W0TiS)`.g>_D0
+?>FP%s8R0<DeNVGkMOn;cdU\1m$V9up\ogEruQ7YmU^h6jk\J3db<[E]XHhln#pHlk2+\7^<kNi
+hu2O,hu;C9h;RS@]B&bdoDa=~>
+nc'0mcaUU+ZD!PQUT:Z/W1f`LrKeauS=ZLV[&^.#SX>b8W3WhNX0fS)c,o5;bHo-hQ_V:4b,^m.
+TDt5pQ'[o/Sti6e['$I)T:M@9SuBEEEm1q`SGfJjVPBo[rLEqVoU%/!ZH9;rf!WH/VO+?^QDhR:
+[DL#-s8U7>`kS_$[@`tr[&01l`4rh"p\rP=ru]D\m_$$LYaV8sX-fcs_m\Rsn'&2^ZCIMqaK_5,
+T;2C_oq25M#F_F!b.Ha0rq$/?~>
+nc'*rZ?pShmb,O`RZNG_Jq3]F,(P8sLP_+UR]F$@e`?/&Uq_5+pQC6[nC"9&c(Ti0C1q:.re^Z-
+(k@![H$k-oLP_%QR\m-saOTA/FcG>4Z','I"-o=DT`(nk[e.-]aOSk7gYKK]i4G(uI\tN\]5rFR
+L&_1,re#WFZK/fbM2@86lJlo1Jc#J2rr4'orUY>Wi7YAoG_1dQeaKa"o^on;_Vi%fIWojXM2@8l
+OS+J0K*R76eaKa"pAX[`J,~>
+nc'*rW+fV4m-*KfgtLE3eC49B,1G&kf%8X0gu%)OkN_E1U;(AZpOdP4nC"*!jk\J2bK7lSrn%2"
+(Xpg[dF-Lnf%8U/gtprIjQGg]A<#:+i;D:2gYCT?rSR5*/*,m<RbQZ1^$4M0daI"7m'L5=EHD0[
+F8g/pC8^@Vg=Os0jQtT0B5d\IKDtlmF8b]EAD-2)f[/."hrj=0ht6QO?ao:Yg="?nd+?n&rn@%s
+rmV2)hrj=0htI'@s*t~>
+nc'*rftb&#ag\=EQ^F87USdmg,,V-1T:M@8Q_((V[D0huWP?3epX%(KnC"P]YaV9#`lcH)rga"`
+(o=:9Y,eFpT:MC;Q^jYEXgPpcZ&Qu:TpGYE"-o4>Rf/fXU\(E6XgQ]ggYKK\]V_$rW1:08`4<h-
+b5_LarlDsc`kSI<SXl1N`7D-+`r#e_rr4(_rU[h0bdX:8Z(mk][EPl4o^p_Cah4L;W3Nk;S=H#H
+Qh?mJUBd?][EPl4pAX[`J,~>
+nc'*u\:Aq>T&AebaL\XRR[*`2+-i:`VQ7;CaOT56hQihocf9S/rKDrco\?(sfs-KfIf+R4J:`B,
+M2@7SQ("SN[^sQ-e_o`LZZC,kVru=>rON*LaN2X)eH"Fti%+*MXL%-P`i\FBQ&q*)dI*cSmt?Dp
+s+UK+J:`(7dC-*V[`Ia4I=?hJs-*H^+GKgiIXAK`^lsA%TXs(OZJbHOaEMptdAE(bLOsu&I!>7+
+!."Qk#_8APh=.W*pAX[`J,~>
+nc'*uY&A$fS([,kjPf%RgtV\Z*o#K*hV[;OjQGdofqt?Jcf8q`rI]1;o\>qhkht+CqpHG4eC<%#
+f@em4gtprIiT0.al0R*$@pcL1lfI.)i</-$jQ6@'!9j(>/*tuiXm"ldU[-spg=kEGm%J%[Ec_9\
+F8p8uEbXn&iSWPOjQrUXCiTISKDtljF8krNCT?[Zg=4X.iT]X5i:cr_ASLMnhV-W5eGdkrd.P]b
+dJhQ"e(ipGlEB+=rq$/?~>
+nc'*uho<IFU<UQaXeqe^Q^.E7+-i1ZS=ZUVXgPg[ai('bcf<$drQr^Ro\?Un\"T:dW;N\8VPBo[
+SXl19Q'\#4USb0![CjH"`NZeU^r!=SrMB[tXf\i+[/df1]IUqCZ-):l`kK<jQ'dr/ZH9)Zn&``P
+s2tA``P8k(ZD4"_UTMJ>]#2Vgs3UcF+Nj]Y_mm\#W0X3RR\maIZJbHOhn6A>ZCI5MT;/?cX0M?)
+!3Z=%#c<r`]$de>pAX[`J,~>
+nG`s0KRr(&CnoqRi7ZN!`;7%e`5p$Ie_oNRn&(E2ER0%"p4S/"PD.Q^kH_PW^oNoer/_k_R[TnM
+X1#UXaO/Poi9Kaf`2@ZsK6u$j_sQO`hui0-lL"Q=!7:PW0Z1`C`58R!cc#GDeW'"E`4EP$e]#+I
+p4S/"s+UK+Jr+Q8mG6=Ch<MtfL4P$Xs-*B\*rCJ?JDS\YR[Tn\m`*$(q#&EcF-Z%<^TjZ)P)tc`
+on`[/rf@DNR^VM2]&`YcoDa=~>
+nG`s&Ec9mW>*dk.l0.9jj8.^Uj5f:`kNV9ulb&!^@*`TTp2Y6SK6,B6kH:lNinrPgg)Jf%gtglF
+iSihXk3(smm-NE<TjqMPC!p\*mHXZ7"7,=?mJZ>PaL8PS[kPG'\%K5IB@"<`n(!$Vk2YFZjQF7g
+C\Dgjs8R0?F)cJ7M!aEhkNM9I[WZS0s8R`Lru1cQF)p!si8!,DiU".jk4nkrCLN%ck2P=Uh#?"-
+f_*hrg&B\2gYCcSah$R.rq$/?~>
+nG`sVai<8[ZGFc']XP2KX88\8X0&M0[Cj8mbeq,t\'MnXp;tJWd)tbNkJ>0QW1K?Ar0SFgQ^=/4
+Sti0`Xg5(a)G]Yqq6`3HPV^qeC+b/_9q]E?$h`5hi#!m&F&qoCJ.aN2<A[C"97oC(5:b-J(FVQI8B
+]#+0`b5_Las2rF&\\?+q[C*Ta_7%8$aoDCfr;Ri8`k]"&ZD!VOR\n3S^ZP=hk/+XB`3Q>8S<oP/
+R%*c>!1EhR#aLaO`7)<Yq#9mbJ,~>
+nG`s0KnT*^H#n&*_;ObHkPF*YkN_@#n%cGuC:&,:II;^`rIot*PD0&7n\fXgjOM>dr44>qaN2WV
+e_T0HlL+,e_53cF\As8ONIgDKEJV6G_84'kPc0=NC29cLDYe9*[;^)AF0C>achd@tO-f:ti8EnI
+Y18(!Kn]R,L&Zj[NdPo(dI6POQFPP*K8'@*PPkG%rI]rTRd/SIaN`Q/HID9ZrmQFFEL#tQg!RmU
+]"50>WrTU-\d-0pe`rLFm/$;QJ,~>
+nG`s&F)pp:B45;E\(L'6lh]iGli-5ilaF$Q=L;R[C[Q0<rH!&[K6.(jn\AeIlK@6fr8B-cjQ,Fc
+kNM0rm-O&Y\"B1#\Ar`.I;eFo@!T)l\$s#HKqW]l=BVT(>[@550XY4nI:9*ulcK"sk(JTXlfm[#
+afa04qK$`Xs)\3]Edhb3Gf]4:aG@@XI;s?.s+C7L*rU))D2moGjQ,FdltXu;qu4iYBjZ\_lKIBk
+io/kSp##`,#NOn.m"rsQqXXZ:~>
+nG`sWb/s;>^::DQaNVcE_YUne_SjC7bf@E1YdD!X_X>J@rQ<:_d)uCdn^Fke^U:2Br2(sEXf\h8
+[CX#f`6$6HaKD;B\AuJ(b/Wba\%BGoaN2<-]<SoLYHXt,[']V9+Lel$_s?I]p?''(ahk^'`5o+3
+`qmj#s8U7Ab/qiC\@VX_#emh#b/ha*s3U]D*rX1#]"GtjXf\h=ag]^equ5m#^p^u!^ULMNW2?Gc
+opu/Yrh]q$XgQ*^bj>2ss*t~>
+nGa!1Kn]L#JUW9nEGTluXi^IV+/5QrTVZS?Fa;npNe@4^s8Re,s-*K_rqY&rDmSotjS[pakN_@"
+n*eT=U6Kk;DK3VAL#_KZK9Co_NI5ug]5V`#^N@SAG^=\jh>)FPidH6JI`RTGec,I;SooCU`knis
+e*;SaKn]R,L&Zj\Ob%q)EGi"#G2;SJKSBI+PPbA#qi6GYXPrI0mEp6&k4eiSeV&L#F*Y(Lmcrlk
+i7[eR!8[Y4#NtC@V/kMdrUTu=~>
+nGa!'F*%<TDesR;?Wq*9VSrA@+-iFQSY]W*A7sh;IW>7+s8R.]s+C@OrqXo^?)[)UlMTlqlg4!*
+lg)U#Q%ipS>[PFrG2qn;EIr6+I;3B3]3epV^LG;rB4tu5h.le%0]Hk`P\e3dq9T';o9*TuR(g).
+?IS1ZrH!&[s)\3]F+J7FARJcI?Y&!\JTGo4s+C4K*W(;0CSoeOm-Vl.AENXbs3G_(Bjk_Rg$J(j
+l07F)k5a`Fkm-P@l^2,=o_n@\J,~>
+nGa!Xb0'\X`l#[7[^*9F[_DX[+2G%mV5:Q4]>!4AbK0S's8U6as3UfGrqYTi[)U>.^\k_n_SjC5
+bfn8O^qI(YZaRg!_rL(+aNr!'b/(d/]=,/Z^U_J!^;%G;h8/s)0]KsdcGSSaq<\+Xo?=eT_o9a+
+[F=E^rQ<:_s2tAab0J#D]XP8P[_(A`cH=<0s3UZC*W+$u\@0W"`5g*1]B8kds6[qJ^pphlbfRf<
+]Y(`H[/df;]Ec<lbepsKo_n@\J,~>
+nGa!1Kn]R+KS,<NI<p.[_5dEP'le<6G1,&kk(&$VKT_&hL&_1,L&[A9s#'c2N-]QCWj9IZ_nj9c
+Pa-upCMn*4Fa/4[IHp9^p\L&,PD0!uJq3+II=:5?J*hc;JqE[hq1C6nK7g1Vdus^]s8MnoIX-(P
+FO#7#pOrR#L&_1,s+Q/jKS"`'I,B@&o_Oc*rr2t^qu7]9OcG4<G*nVtE-Hd'r;ZfJKnP#*G]InN
+Pd8-Bi:ZOHcbRB9UR%s&I.7"3o)F4~>
+nGa$(F*%B\EcHQoCM@D&_5:T=?N4@H@Dud*fkTYeDt\4'F8p=]s)W8]KDtm.rRuX4@Afp!\%KA_
+]Tn2+GFhuC?=@>UBPM>Jmsk*.JocQcrdf$,l/c\rjl^LJDf9T6p%J3$/GO4)SoN#-rm:]Eqj_J8
+A&2X"C$kY9s)W8]s)\3]F+\LPDJX(FCMre(a)K6.%l!/(1K*WCV=GK=BRM5O]lD"RZ*s3Ph-Deirn
+AS?gq\%:5blO1bA\%S)`X(,o6qYp'cJ,~>
+nGa$Yb0'b`aiMZk_SEk,_7(a)#R[K!ZL\Ac).ftlgi`qIO#b5]Was2rLad/O&&rU%_A\>Q[PaMYp:
+`5'!u\Xp(4[CEf]^VRePn'(P&ccXVWrm&R(l/fe!jlaSL`l?'>p%J4&/GR<-fZ<@)rpBabqpr[!
+]"tr&_!Um=s2rLas2tAab0\8N`P]OL_Su0Dd)u@f!7:WC*<+7,`5o:#^U1G^_t<m,s6[tN`koF!
+ZF%<aaMRSn$d6T3`500g]#!n4rpp)>~>
+nGa!1Kn]R,KnY]dK7\[@kg'*Ss*bXHJFW8`q1OG#Kp.5jL&_1,L&[A8s"<;nJUZ7pF)eXrE4U+4
+Fa)>]I!pHoJV&K+qYZNUs-&/#L&[?iK_kIrKD>7qqu26ML&V)IKc'iDKs$-\PQ056s8K*PJUcm5
+mXk<6L&Zl+rt'naKnY_EKS4u1pOe.trf`'8rrA8ZruI;cO6MFEGh%1lK)GWJs42mXKS+f(L3Ri]
+E3X7rrbE.@C20K<CMRa'DfE:/bh7GsqYp$bJ,~>
+nGa!'F*%B]F)us0EH#j_kfWg=s(iA6DXm@=q/UQUF+\Q6F8u8]F8pmks"E8\Df"(L@:-IN?b0ZT
+A7a8(C27X'DfB]9qYZ!Fs+>BFF8pl6Er,QNEVT?Mqf;[Ws8Mh8)#nYuU3"\6s3UfGrh+7LD<Pj)
+E;KNSs)\2>&9IkmF+\OTEcH*nEH;$WK6.%l!/(.J*J8oml$$cPeS8uAr;Q`rcuX8KEGoZ:An,7V
+Z!1E2=V@H2=JDQn=^#$8?FjUifkbX(rpg#=~>
+nGa!Xb0'bab0&',aN)<ekhZ0Rs2,N8`UWTAq8peYb0\<2b5_Lab5]ies"Erg`l$HP\@/iR[^ruZ
+]=cY._8=+/`lH0AqY\_>s3Sp8b5]i2ankeRaS>SQqoSi[s8Mi:)#qb$grf$2s6]jdrn>H5`9>/-
+a85bWs2t?@&Bb$qb0\;RaiMQtaN=D[d)u@f!7:TB*RN*Ul,:<Le\T5Gr;Q`rmE3SnaMu-8]t1_^
+Z*LY6YS*\7YbInsYd(L@[CWomfu(l,rpg#=~>
+nGa!1Kn]R,KnY`jKnP-Vq=so@(ANN7qLneFL&_1,s+QYjs+ULQKn]PjrVmSmPD"S[m='KDidKp;
+It3+@JqAW-re1<*s8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L%'G;;K_^;u
+K`;"*s+UIP"GQl0Kp2Fg#6'=1s8S::rr2t^qZ$SZ#a5"EJV!BDKS9=(!7q+&$&!qlJUi2ti8&bZ
+HN2V.HJ$nsH@(!dIH>tHo7M_qnGe"~>
+nGa!'F*%B]F*!!6F)uC!q=so.(AMlhqJuN4F8u8]s)Wg6s)\5?F*%A6rVmJfK5tu'm;6Y!ibRXl
+D/O:_E;jkWErL.[rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%RU2t?qq/Z@R
+rr7'>F8l1BF8p<&KD]cprc</\s+>Clrr@]Js8R]WK)'q8Dt7mgF8c+=d/A"lEcHVJDJX+Hh.ck%
+s4@Eef\'s;BaAHhj_aGWEH;'Js*t~>
+nGa!Xb0'bab0&*2b0%j'q=sp0(APtlqT8[6b5_Las2r^2s2tBAb0'b2rVmK$d)jB#mDQm%ikjfp
+`5Taea8X0[ao9H_rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ogrda\q8rNV
+rr:.@b5VDDb5]W,d/;#jrlWC`s3SpfrrCFBs8UFOchYi*`q%3mb5M>?mJY06aiM`H`P]RNh8'$)
+s4(a)Fgf\+%=^^.cnji$TYaN=GNs*t~>
+nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]%-3V+L&Ln$KD>4opk/R!
+!<)\Hs8N^qs8S::PD0%#Kn]R,Kn]R,L&_+*s8VnK#lfU4Y(bGjs472L!3Z<T#lfVYL&_1,s+UIP
+"GQl0Kp2Fg"oj:1s8S;]rrA8Zs8J2brfVqfrVhNLrrCXIKa*]nKS+pOpAKUCoE'X;p&0LBK*D%'
+qu)5&n,In~>
+nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M%,cbZF8buUEVT<Kpi6:R
+!<)\6s8N^as8R^mK6.'FF*%B]F*%B]F8u2[s8Vn9#leseU3"\6s3UcF!2BI6#leuGF8u8]s)\2>
+"EXTaF+aC3"oiXbs8R`Mrr@]Js8IWRre#63rVgm:rrCFCEs@8;EcH*npAJt1oE'")p&8q0E<Z,X
+qu(SWn,In~>
+nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E%.higb5M4YaS>POprNHV
+!<)]8s8N_Ys8UHgd)uC8b0'bab0'bab5_F_s8Vo;#li&igrf$2s6]gc!8RRr#li'Ib5_Las2t?@
+"Npbeb0^(/"ol`fs8UIErrCFBs8L@Jrm8d/rVjt<rrDH`ap-57aiMQtpAN&3oE*)+p&<#2a9D@\
+qu+[[n,In~>
+nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO
+s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Ss+Q00L";Iff)G[LY5X+\s+UK,s8RfQL&V)T
+L&Zj\s87QSs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dA8s8MtNs8<"Prr2eK"oj;Vs+Q0q
+s*t~>
+nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!=
+s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3>s)\3]s8R0?F8l1B
+F8p<&s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(5ks8Mt<s8<"?rr2e9"oiZDs)W8M
+s*t~>
+nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(?
+s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G%s2tAas8U7Ab5VDD
+b5]W,s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:\es8Mu>s8<#Arr2f;"olaFs2rLQ
+s*t~>
+nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO
+s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Ss+Q00L";Iff)G[LY5X+Zs+UK,s8RfNrre&U
+Kn]R)Ka%L1L&_1:rVlk]qZ$PY"TO[>L&_.+rVllKqh5$6rIt:OrIt:O!ep[Sqh54RL&_1,L%#%l~>
+nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!=
+s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^As)W7UF3oR>d/O%FUAf3<s)\3]s8R0<rrdEC
+F*%BZEs;SbF8u8mrVlkMqZ$PI"TO*qF8u5\rVllEqf;airH&#=rH&#=!d"DAqf;r@F8u8]F79-Z~>
+nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(?
+s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G#s2tAas8U7>rrgLE
+b0'b^ap%gfb5_LgrVllEqZ$QA"TQikb5_I`rVllbqoSocrQ>0?rQ>0?!m:QCqoT*Bb5_Lab4#@\~>
+nG`O$L&V,PK`RD;re:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO
+s7h<Jrt:Oqs-&/#L&[?jL&_1,L&_1,s8@ZOs7q?Qs+Q00L";IcrrB5$Ka.R2s+ULQL&CrRL&Zj\
+s87QSs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q
+J,~>
+nG`NoF8l4>ErgpnrcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M$fHYYF8u8]F8u8]s8@!=
+s7g[8rt9tas+>BFF8pl6F8u8]F8u8]s8@$=s7p^?s)W7UF3oR;rrAemEsDYcs)\5?F8Z%@F8p<&
+s86pAs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM
+J,~>
+nG`OKb5VG@aoTlhrlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(?
+s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seAs2rL>b3dRRrrCjRap.mgs2tBAb5D8Bb5]W,
+s8:"Cs2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q
+J,~>
+nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPtLhjHG:Os8Re,s8RfQrIk7O
+pkAbJ&sN@qPD,3Ss-&.js8Re,s8RfQrIt:Oq1T%QKnZ[`es$%3!3Z<T#60DWL&_1,r;QqSs+Q1,
+s8@WTs+Q1,s-*E]!0d9Zrf[KbPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q
+J,~>
+nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5(a)KDkfXi.H)ls8R.]s8R0?rGqu=
+piHK8&qg5aK6)Zds+>B6s8R.]s8R0?rH&#=q/Zc?F*"'sd"D8r!2BI6#6/cEF8u8]r;QqAs)W8]
+s8@!Bs)W8]s+C:M!/(.Jrdt@RK6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM
+J,~>
+nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/EtPo?bY&s8U6as8U7ArQ5-?
+pr`X:'%$[Yd)s_Xs3Sp2s8U6as8U7ArQ>0?q8rpAb0&M^mEke2!8RRr#62jGb5_Lar;QrCs2rLa
+s8C(Ds2rLas3U`E!7:TBrm1fJd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q
+J,~>
+nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J
+L&_/cPQ1ZHKp.5js+Q1,s+Q1,s+ULOL&_2KKa.R2Ks$-\PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R,
+rIkFTKn]R,PPtL]PPY:aPQ-jHPD+_jre:=N!7q%$!0dD9rr;qNs8N.Ss8W(P#lfU4s+ULQKn]!q
+J,~>
+nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78
+F8u7QKE(t(F+\Q6s)W8]s)W8]s)\5=F8u:9EsDYcF/!a&KDb`LUAf3<s)\3]s8R0<rrmKDF*%B]
+rGr/BF*%B]KDkfMKDPTQKE$T(K6),6rcA&<!7:Ua!/(8lrr;q<s8N.As8W(>#leses)\5?F*$gM
+J,~>
+nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/<nNd)sN2s2rLas2tB?aoMJ:
+b5_JSd/X-mb0\<2s2rLas2rLas2tB?b5_M;ap.mgb1t/,d/<nDh#>G#s2tAas8U7>rrpRFb0'ba
+rQ5<Db0'bad/EtEd/*bId/VJmd)sN2rlY3>!:B[+!7:_frr;r>s8N/Cs8W)@#li&is2tBAb0'2Q
+J,~>
+nG`O$L&V,PK`RD;re:@OrIka]Kn]P\s8RfQs+UK,PD/u8s+LLRPPkFfPD+_js+Q1,s+ULOK`M/J
+L&_/QPQ(R`Kp.5irs4>Ys+Q1,s+ULOL&V,KKa.R2Ks(I,PPkF\Y5X+Zs+UK,s8RfNrrn,VKn]R,
+rIkFTKn]R,PPtL]PPY:cPQ-jHPD+_jKn]I)!7q%$!0dD9rr;qNs8N.Ss8W(P#QKL3s+ULQL$ntk~>
+nG`NoF8l4>ErgpnrcA)=rGrJKF*%A&s8R0?s)\3]K6."ks)S5@KDb`VK6),6s)W8]s)\5=Erc78
+F8u7?KDtlPF+\Q5rs3]Gs)W8]s)\5=F8l49EsDYcF/&]]KDb`LUAf3<s)\3]s8R0<rrmKDF*%B]
+rGr/BF*%B]KDkfMKDPTSKE$T(K6),6F*%9Z!7:Ua!/(8lrr;q<s8N.As8W(>#QJjds)\5?F70'Y~>
+nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/<nNd)sN2s2rLas2tB?aoMJ:
+b5_JAd/O%Hb0\<1rs6dIs2rLas2tB?b5VG;ap.mgb2!$ad/<nDh#>G#s2tAas8U7>rrpRFb0'ba
+rQ5<Db0'bad/EtEd/*bKd/VJmd)sN2b0'Y^!:B[+!7:_frr;r>s8N/Cs8W)@#QMrhs2tBAb3o:[~>
+nG`O$L&V,PK`RD;re:@OrIkLVKn]P\s8RfOrrRn<L&M&OK`V4;r;R+fs+ULQKn]R,L&_+*!<;hJ
+qu6_OPD/o6s+ULQ!/:FPs+UIPrIkCSKn]P\rr3#MPPkFaY5a30s+UFO!/:@N%u(%;L&_1,s+Q1,
+Kn]R,PPtL]PPY:cPQ-jHPD+_jKn]I)!7q%$!0dD9rr;qNs8N.Ss8W(P#QKL3s+ULQL$ntk~>
+nG`NoF8l4>ErgpnrcA)=rGr5DF*%A&s8R0=rrR7oF8c.=Erl;nr;R+Vs)\5?F*%B]F8u2[!<;h8
+qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`QUAo:Us)\/=!-A)<%s.blF8u8]s)W8]
+F*%B]KDkfMKDPTSKE$T(K6),6F*%9Z!7:Ua!/(8lrr;q<s8N.As8W(>#QJjds)\5?F70'Y~>
+nG`OKb5VG@aoTlhrlY6?rQ5BFb0'b,s8U7?rrU?ib5MA?aoVOhr;R,Ns2tBAb0'bab5_F_!<;i:
+qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/<nIh#GO>s2t<?!6Y6>&'Fppb5_Las2rLa
+b0'bad/EtEd/*bKd/VJmd)sN2b0'Y^!:B[+!7:_frr;r>s8N/Cs8W)@#QMrhs2tBAb3o:[~>
+nG`O$L&V,PK`RD;re:@Os+LUUL&Zj\rVlkOrVlqQPD/u8s+LLRPPkFfPQ-@:s+Q1,s+ULOK`h@/
+s+UFOs+U@M!elhlqu?\Ms8N(Qrr<"Prr;qN"TO10s+UIP!S3J4rr]G(Kn]F(!/:@N%u(%;L&_1,
+s+Q1,Kn]R,PPtL]PPY:bPQ-jHPD+_jL&:lMf)::(s+Q[9L&V,NL&_/SL&_2PKa7X3L&Zl,s+Tn@
+J,~>
+nG`NoF8l4>ErgpnrcA)=s)S>CF8p<&rVlk=rVlq?K6."ks)S5@KDb`VKE$#ms)W8]s)\5=Es)G`
+s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%6Y!-A)<%s.blF8u8]
+s)W8]F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4<F8u7AF8u:>EsM_dF8p=]s)[W.
+J,~>
+nG`OKb5VG@aoTlhrlY6?s2kKEb5]W,rVll?rVlrAd)u=es2kBBd/<nNd/V8gs2rLas2tB?aoh[d
+s2t<?s2t6=!m8m4qu?]=s8N)Arr<#@rr;r>"TQWes2t?@!U\83rr_'Vb0'V]!6Y6>&'Fppb5_La
+s2rLab0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG>b5_JCb5_M@ap7shb5]Was2sd0
+J,~>
+nG`O$L&V,PK`mV>L&Zl+s8RcUs+UK,L&M#OL&M#QKp.5hs8RcRs-*B\!gEY<rr3C\s8RfQs+UK,
+s+UK,rVunOqu6_OPD/o6s+ULQ!/:FPs+UIPrIkCSKn]P\rr3#MPPkF_Y5a30qu6YMr;R:]s+Q1,
+s+UK,L&Zj\s8S;]rrA8Zrs4hgPQ-i#L&Zl(rrCXKK`_:.PQ$:8s8@ZOrrRoSs8I]Ws+Q1,L&_1,
+mf.e~>
+nG`NoF8l4>Es.-qF8p=\s8R-Cs)\3]F8c+=F8c+?F+\Q4s8R-@s+C7L!e^Morr3CJs8R0?s)\3]
+s)\3]rVun=qu6_=K6-qis)\5?!-A/>s)\2>rGr,AF*%A&rr3#GKDb`OUAo:Uqu6Y;r;R:Ks)W8]
+s)\3]F8p<&s8R`Mrr@]Jrs48WKE$RFF8p=YrrCFEEruA_KDorks8@$=rrR9As8I'Es)W8]F8u8]
+mf.e~>
+nG`OKb5VG@aop)kb5]W`s8U4Es2tAab5M>?b5M>Ab0\<0s8U4Bs3U]D!mptirr3DLs8U7As2tAa
+s2tAarVuo?qu6`?d)u7cs2tBA!6Y<@s2t?@rQ59Cb0'b,rr3#dd/<nGh#GO>qu6Z=r;R;Ms2rLa
+s2tAab5]W,s8UIErrCFBrs7!Od/VJ8b5]W]rrDHbao_Ucd/M2es8C+?rrU(a)Cs8L.Gs2rLab5_La
+mf.e~>
+nG`O$L&V,PK`[J<L&CuNK`qF0s+Q1*rr@cOrrRn<L&M&OK`V4;r;Qh^s+UIP%#+`]L&_1,s+UK,
+s+UFOs+U@M!elhlqu?\Ms8N(Qrr<"Prr;qN"TO10s+UIP!S3J4rr]G(Kn]4"%u(%;L&_1,s+Q1,
+Kn]R,PPtL]PPY:bPQ-jHPD+_jL&:lMf)::(s+Q[9L&V,PKa.R2s8RfQs8I]Ws+Q1,L&_1,mf.e~>
+nG`NoF8l4>Erq!oF8Z(<Es2Mas)W8[rr(a)-=rrR7oF8c.=Erl;nr;QhNs)\2>%!2IKF8u8]s)\3]
+s)\/=s)\);!cs!8qu?\;s8N(?rr<">rr;q<"TNOas)\2>!RQJsrr]"qF*%$S%s.blF8u8]s)W8]
+F*%B]KDkfMKDPTRKE$T(K6),6F8Pt;d/A"es)WhlF8l4>EsDYcs8R0?s8I'Es)W8]F8u8]mf.e~>
+nG`OKb5VG@ao]rib5D;>aoqaes2rL_rrC4?rrU?ib5MA?aoVOhr;QiFs2t?@%*JVMb5_Las2tAa
+s2t<?s2t6=!m8m4qu?]=s8N)Arr<#@rr;r>"TQWes2t?@!U\83rr_'Vb0'DW&'Fppb5_Las2rLa
+b0'bad/EtEd/*bJd/VJmd)sN2b5;2=mJY0/s2r^fb5VG(a)ap.mgs8U7As8L.Gs2rLab5_Lamf.e~>
+nG`O$L&V,PK`[J<L&:lRL&Zl,Kn]L*!/:CO!elhlrVunO!WSA]rrSDaL&V)\L&_1,s8RfQL&Zl,
+L&M&OL&:lOKp.5fs8RfQrr@cPs8RfPs8@WSs+Q1,L&V)Qes$%3"0VZXL%YHVL&Zj\s8RfQKn]P\
+L&_1:rVlk]qYphbs-*JHKn]P\qu6ZIrIk=QKp2Lirr<"P#60DWs+ULQre:CP"blu1s8Rf@s*t~>
+nG`NoF8l4>Erq!oF8Pt@F8p=]F*%<[!-A,=!cs!8rVun=!WRfMrrRiQF8l1JF8u8]s8R0?F8p=]
+F8c.=F8Pt=F+\Q2s8R0?rr@->s8R0>s8@!As)W8]F8l1?d"D8r"/>g:F7oPDF8p<&s8R0?F*%A&
+F8u8mrVlkMqYphRs+C?(F*%A&qu6ZCrGr&?F+aI5rr<">#6/cEs)\5?rcA,>"`s]bs8R0.s*t~>
+nG`OKb5VG@ao]rib5;2Bb5]Wab0'\_!6Y9?!m8m4rVuo?!WUOErrURIb5VDLb5_Las8U7Ab5]Wa
+b5MA?b5;2?b0\<.s8U7ArrC4@s8U7@s8C(Cs2rLab5VDAmEke2"5Nq!b4YcFb5]W,s8U7Ab0'b,
+b5_LgrVllEqYpiJs3Uemb0'b,qu6Z`rQ53Ab0^.1rr<#@#62jGs2tBArlY9@"j6kfs8U70s*t~>
+p]#dES,i?aJ,~>
+p]#dES,i?aJ,~>
+p]#dES,i?aJ,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~>
+o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~>
+o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4<TETKr2KbWh#Dm~>
+pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A
+<TEWL!35qs!-6lpJ,~>
+pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A
+<TEWL!35qs!-6lpJ,~>
+pAY0R<W2suEp<T)j)XYhs&K$t!TS4irr=)<!!((9s8V-ArrC+=s8T+err`=^s/H(ls8Q*krr[9A
+<TEWL!35qs!-6lpJ,~>
+pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[
+n,EEg!8%7$~>
+pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[
+n,EEg!8%7$~>
+pAY:r3TL.>j6?REj)XYhs&K$t!TS4grrE,"q#C@okPkR_!<3#uWpfrl`rK->EWF/Rs8Q*krrE+[
+n,EEg!8%7$~>
+pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&>
+*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z
+ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts
+s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~>
+pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&>
+*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z
+ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts
+s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~>
+pAY-nEr>qDEo[2[ElS0?<HA*=(33Dqj5Y1#<HA,>WrN+!<HA-"ElV1#qu?[rrVunts8N@b<E6&>
+*KF."q>WDSWrN+ZElV1?j&I*?<TF,><E5(ZWiD(ZWrN*Z<H@."s,L*>j)R-[<N?(>j8]."<N?)Z
+ElV1?qYpb[!'1'>!36%u%rt[Ms8V+Z<B4(Zs)M+[j8Aogj&H(><TF,><E8)ZElW3#j8AoXWW;ts
+s)J7&<N9&>rr3ML<E7*>s2S,[a8b1?<E8)Qs*t~>
+pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[
+3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'>
+<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%;
+!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~>
+pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[
+3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'>
+<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%;
+!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~>
+pAY+mrW";dWrE(!s/H(!!!$">ErT,[<?6+[!!#"ZW`<(!WW6$>EiK*>3<6)Ws8Q*ts8Q(,s)K,[
+3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[<TE*[3E6("<<*"Z!<6%!3?;-"NW<'"EcO/?<N?'!WrH'>
+<<1(>!!#"Za8>lS<<*%!!$-+[s&C(>!6=+"3E6&Zs&C(>*HM)X&B@cN3E>,"*B?,#rr<$>*EE%;
+!NH.u<>smt!$)%>*<<,>WW4&"!<;'Z3B8,[*B@+?WqQIC~>
+p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2?
+s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+"
+<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u
+<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~>
+p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2?
+s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+"
+<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u
+<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~>
+p&?N%WiB&!irH+ZWW<&!NrQ*Z`rM,[!33%!WrF*[<E9&>ErV."WW9(!*QS*Xs&K$ts&BI,EZL2?
+s/H(Zs&E(qruqHCs8T)!<W<'!s&E)!s)K-?*?F0?*TP0\`rN.><E8&ZNrAtYWW<%u%03EK!6>+"
+<N6%!rrB(rrttfW!-/'[<WC)>a8\/"EZP2[<E7'>N]@*>qYq$*WrN*>*WP."WW6'!EcV*X!NH.u
+<>"7k*TI-[rrB)!*EE->!<5&>rVlp>3QLdlJ,~>
+nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq
+('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l*
+WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)!
+WW<&!Wr;r"j)P-"p&BO~>
+nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq
+('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l*
+WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)!
+WW<&!Wr;r"j)P-"p&BO~>
+nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTo<W2st<WE(*NZB/#WW<)!<E8nq
+('(B7s/H(ZrrB)!<E9)!<<+%[j8W+Zrr35'!<<(!<N6&srrK,"rr3E-Wi?(!s&E(!!9=(ZWr2l*
+WW;'"!*-$!s/H)!s8>sts8Q(%WW3$!a8,`C!36)!<E9)!!3-%!q>UJq!;uls<=]$/WrE'>rrB)!
+WW<&!Wr;r"j)P-"p&BO~>
+p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-"
+WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+>
+iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t
+s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~>
+p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-"
+WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+>
+iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t
+s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~>
+p\u.P<WE*>3<8([WrK(!rrB)!<?9*[WrL+>WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+><E9(!j8U-"
+WW<(Z*HM)X(rrWVEiT/>!<<'!WrH(!s8R*[j8Y."<E9%u%`\Ris#F*"!36'ZWrK(!rr3E-WlG+>
+iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?<Q>*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t
+s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~>
+p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u!
+*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)!
+!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[
+WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~>
+p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u!
+*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)!
+!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[
+WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~>
+p\t5nr;Zp?WrI,<!!*&t!!92#<W2t"<N6&ts8Q("s/Q%u!lq;@q#:=orW!*BW`<(!*W?'=Wr;u!
+*TR(t!$2"<%EGIKs8N)!s&E)!s5P.!!!90#<W2pt3W/pYs&K$u"02C$!<3!-!36'!!!"&>WW<)!
+!35tss&BR/WW;)Z<HA+>!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[
+WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~>
+pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z
+WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z
+#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2"
+WlP/>j/T-Os*t~>
+pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z
+WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z
+#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2"
+WlP/>j/T-Os*t~>
+pAY6TWiF,<rs6ZFa2e2[EiS1!rrpHCa8c1[rVuoXs8N8_WoO-Za8#ZHj/T->s8V->s8T+!j8Z+Z
+WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z
+#fluFWiH+!a/]+<s/Q+Zs8N/@WlOr8!?K5Zrrf@Bs8U.6rrC+<<<2(YrtKM6s5W/>s2V/"a8c2"
+WlP/>j/T-Os*t~>
+l2LbaWmUhIWW7VMec1.~>
+l2LbaWmUhIWW7VMec1.~>
+l2LbaWmUhIWW7VMec1.~>
+l2Lc)a3jnf`uTa2ec1.~>
+l2Lc)a3jnf`uTa2ec1.~>
+l2Lc)a3jnf`uTa2ec1.~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+JcCT,J,~>
+%%EndData
+showpage
+%%Trailer
+end
+%%EOF
Added: branches/bos/thirdparty/emacs/slime/doc/slime-small.pdf
==============================================================================
Binary file. No diff available.
Added: branches/bos/thirdparty/emacs/slime/doc/slime.texi
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/slime.texi Fri Jan 18 06:05:59 2008
@@ -0,0 +1,2963 @@
+\input texinfo
+@c %**start of header
+@setfilename slime.info
+@settitle The Superior Lisp Interaction Mode for Emacs
+
+@dircategory Emacs
+@direntry
+* SLIME: (slime). Superior Lisp Interaction Mode for Emacs.
+@end direntry
+@c %**end of header
+
+@set EDITION 3.0-alpha
+@set SLIMEVER 3.0-alpha
+@c @set UPDATED @today{}
+@set UPDATED @code{$Date: 2007/11/27 13:16:52 $}
+@set TITLE SLIME User Manual
+@settitle @value{TITLE}, version @value{EDITION}
+
+@copying
+Written by Luke Gorrie.
+
+Additional contributions: Jeff Cunningham,
+
+This file has been placed in the public domain.
+@end copying
+
+@titlepage
+@title @value{TITLE}
+@titlefont{version @value{EDITION}}
+@sp 2
+@center @image{slime-small}
+@sp 4
+@subtitle Compiled: @value{UPDATED}
+
+@page
+@insertcopying
+
+@end titlepage
+
+@c Macros
+
+@macro SLIME
+@acronym{SLIME}
+@end macro
+
+@macro SLDB
+@acronym{SLDB}
+@end macro
+
+@macro REPL
+@acronym{REPL}
+@end macro
+
+@macro CVS
+@acronym{CVS}
+@end macro
+
+@macro kbditem{key, command}
+@item \key\
+@itemx M-x \command\
+@kindex \key\
+@findex \command\
+@c
+@end macro
+
+@macro kbditempair{key1, key2, command1, command2}
+@item \key1\, M-x \command1\
+@itemx \key2\, M-x \command2\
+@kindex \key1\
+@kindex \key2\
+@findex \command1\
+@findex \command2\
+@c
+@end macro
+
+@macro cmditem{command}
+@item M-x \command\
+@findex \command\
+@c
+@end macro
+
+@macro kbdanchorc{key, command, comment}
+@anchor{\command\}
+@item \key\
+@code{\command\}
+@i{\comment\}@*
+@end macro
+
+@macro fcnindex{name}
+@item \name\
+@xref{\name\}.
+@end macro
+
+@c Merge the variable and concept indices because both are rather short
+@synindex cp vr
+
+
+@c @setchapternewpage off
+@c @shortcontents
+@contents
+
+@ifnottex
+@node Top
+@top SLIME
+
+@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs''. This is
+the manual for version @value{SLIMEVER}.
+
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction::
+* Getting started::
+* slime-mode::
+* REPL::
+* Debugger::
+* Misc::
+* Customization::
+* Tips and Tricks::
+* Contributed Packages::
+* Credits::
+* Key Index::
+* Command Index::
+* Variable Index::
+
+@detailmenu
+ --- The Detailed Node Listing ---
+
+Getting started
+
+* Platforms::
+* Downloading::
+* Installation::
+* Running::
+* Setup Tuning::
+
+Downloading SLIME
+
+* CVS::
+* CVS Incantations::
+
+Downloading from CVS
+
+* CVS Incantations::
+
+Setup Tuning
+
+* Autoloading::
+* Multiple Lisps::
+* Loading Swank faster::
+
+Using slime-mode
+
+* User-interface conventions::
+* Commands::
+* Semantic indentation::
+* Reader conditionals::
+
+User-interface conventions
+
+* Temporary buffers::
+* Inferior-lisp::
+* Multithreading::
+* Key bindings::
+
+Commands
+
+* Programming::
+* Compilation::
+* Evaluation::
+* Recovery::
+* Inspector::
+* Profiling::
+* Other::
+
+Programming commands
+
+* Completion::
+* Indentation::
+* Documentation::
+* Cross-reference::
+* Finding definitions::
+* Macro-expansion::
+* Disassembly::
+
+REPL: the ``top level''
+
+* REPL commands::
+* Input Navigation::
+* Shortcuts::
+
+SLDB: the SLIME debugger
+
+* Examining frames::
+* Restarts::
+* Frame Navigation::
+* Stepping::
+* Miscellaneous::
+
+Misc
+
+* slime-selector::
+* slime-macroexpansion-minor-mode::
+* Multiple connections::
+
+Customization
+
+* Emacs-side customization::
+* Lisp-side::
+
+Emacs-side
+
+* Hooks::
+
+Lisp-side (Swank)
+
+* Communication style::
+* Other configurables::
+
+Tips and Tricks
+
+* Connecting to a remote lisp::
+* Global IO Redirection::
+* Auto-SLIME::
+
+Connecting to a remote lisp
+
+* Setting up the lisp image::
+* Setting up Emacs::
+* Setting up pathname translations::
+
+Contributed Packages
+
+* Loading Contribs::
+* Compound Completion::
+* Fuzzy Completion::
+* slime-autodoc-mode::
+* ASDF::
+* Banner::
+* Editing Commands::
+* Fancy Inspector::
+* Presentations::
+* Typeout frames::
+* TRAMP::
+* Documentation Links::
+* Xref and Class Browser::
+* Highlight Edits::
+* inferior-slime-mode::
+* Scratch Buffer::
+* slime-fancy::
+
+@end detailmenu
+@end menu
+
+@c -----------------------
+@node Introduction
+@chapter Introduction
+
+@SLIME{} is the ``Superior Lisp Interaction Mode for Emacs.''
+
+@SLIME{} extends Emacs with support for interactive programming in
+Common Lisp. The features are centered around @code{slime-mode}, an
+Emacs minor-mode that complements the standard @code{lisp-mode}. While
+@code{lisp-mode} supports editing Lisp source files, @code{slime-mode}
+adds support for interacting with a running Common Lisp process for
+compilation, debugging, documentation lookup, and so on.
+
+The @code{slime-mode} programming environment follows the example of
+Emacs's native Emacs Lisp environment. We have also included good
+ideas from similar systems (such as @acronym{ILISP}) and some new
+ideas of our own.
+
+@SLIME{} is constructed from two parts: a user-interface written in
+Emacs Lisp, and a supporting server program written in Common
+Lisp. The two sides are connected together with a socket and
+communicate using an @acronym{RPC}-like protocol.
+
+The Lisp server is primarily written in portable Common Lisp. The
+required implementation-specific functionality is specified by a
+well-defined interface and implemented separately for each Lisp
+implementation. This makes @SLIME{} readily portable.
+
+@c -----------------------
+@node Getting started
+@chapter Getting started
+
+This chapter tells you how to get @SLIME{} up and running.
+
+@menu
+* Platforms::
+* Downloading::
+* Installation::
+* Running::
+* Setup Tuning::
+@end menu
+
+@c -----------------------
+@node Platforms
+@section Supported Platforms
+
+@SLIME{} supports a wide range of operating systems and Lisp
+implementations. @SLIME{} runs on Unix systems, Mac OSX, and Microsoft
+Windows. GNU Emacs versions 20, 21 and 22 and XEmacs version 21 are
+supported.
+
+The supported Lisp implementations, roughly ordered from the
+best-supported, are:
+
+@itemize @bullet
+@item
+CMU Common Lisp (@acronym{CMUCL}), 19d or newer
+@item
+Steel Bank Common Lisp (@acronym{SBCL}), 1.0 or newer
+@item
+OpenMCL, version 0.14.3 or newer
+@item
+LispWorks, version 4.3 or newer
+@item
+Allegro Common Lisp (@acronym{ACL}), version 6 or newer
+@item
+@acronym{CLISP}, version 2.35 or newer
+@item
+Armed Bear Common Lisp (@acronym{ABCL})
+@item
+Corman Common Lisp (@acronym{CCL}), version 2.51 or newer with the
+patches from @url{http://www.grumblesmurf.org/lisp/corman-patches})
+@item
+Scieneer Common Lisp (@acronym{SCL}), version 1.2.7 or newer
+@end itemize
+
+Most features work uniformly across implementations, but some are
+prone to variation. These include the precision of placing
+compiler-note annotations, @acronym{XREF} support, and fancy debugger
+commands (like ``restart frame'').
+
+@c -----------------------
+@node Downloading
+@section Downloading SLIME
+
+You can choose between using a released version of @SLIME{} or
+accessing our @CVS{} repository directly. You can download the latest
+released version from our website:
+
+@url{http://www.common-lisp.net/project/slime/}
+
+We recommend that users who participate in the @code{slime-devel}
+mailing list use the @CVS{} version of the code.
+
+@menu
+* CVS::
+* CVS Incantations::
+@end menu
+
+@c -----------------------
+@node CVS
+@subsection Downloading from CVS
+
+@SLIME{} is available from the @CVS{} repository on
+(a)file{common-lisp.net}. You have the option to use either the very
+latest code or the tagged @code{FAIRLY-STABLE} snapshot.
+
+The latest version tends to have more features and fewer bugs than the
+@code{FAIRLY-STABLE} version, but it can be unstable during times of
+major surgery. As a rule-of-thumb recommendation we suggest that if
+you follow the @code{slime-devel} mailing list then you're better off
+with the latest version (we'll send a note when it's undergoing major
+hacking). If you don't follow the mailing list you won't know the
+status of the latest code, so tracking @code{FAIRLY-STABLE} or using a
+released version is the safe option.
+
+If you checkout from @CVS{} then remember to @code{cvs update}
+occasionally. Improvements are continually being committed, and the
+@code{FAIRLY-STABLE} tag is moved forward from time to time.
+
+@menu
+* CVS Incantations::
+@end menu
+
+@c -----------------------
+@node CVS Incantations
+@subsection CVS incantations
+
+To download @SLIME{} you first configure your @code{CVSROOT} and login
+to the repository.
+
+@example
+export CVSROOT=:pserver:anonymous@@common-lisp.net:/project/slime/cvsroot
+cvs login
+@end example
+@emph{(The password is @code{anonymous})}
+
+The latest version can then be checked out with:
+@example
+cvs checkout slime
+@end example
+
+Or the @code{FAIRLY-STABLE} version can be checked out with:
+
+@example
+cvs checkout -rFAIRLY-STABLE slime
+@end example
+
+If you want to find out what's new since the version you're currently
+running, you can diff the local @file{ChangeLog} against the
+repository version:
+
+@example
+cvs diff -rHEAD ChangeLog # or: -rFAIRLY-STABLE
+@end example
+
+@c -----------------------
+@node Installation
+@section Installation
+
+With a Lisp implementation that can be started from the command-line,
+installation just requires a few lines in your @file{.emacs}:
+
+@vindex inferior-lisp-program
+@vindex load-path
+@example
+(setq inferior-lisp-program "@emph{the path to your Lisp system}")
+(add-to-list 'load-path "@emph{the path of your @file{slime} directory}")
+(require 'slime)
+(slime-setup)
+@end example
+
+@iftex
+The snippet above also appears in the @file{README} file. You can
+copy&paste it from there, but remember to fill in the appropriate
+paths.
+@end iftex
+
+We recommend not loading the @acronym{ILISP} package into Emacs if you
+intend to use @SLIME{}. Doing so will add a lot of extra bindings to
+the keymap for Lisp source files that may be confusing and may not
+work correctly for a Lisp process started by @SLIME{}.
+
+@c -----------------------
+@node Running
+@section Running SLIME
+
+@SLIME{} is started with the Emacs command @kbd{M-x slime}. This uses
+the @code{inferior-lisp} package to start a Lisp process, loads and
+starts the Lisp-side server (known as ``Swank''), and establishes a
+socket connection between Emacs and Lisp. Finally a @REPL{} buffer is
+created where you can enter Lisp expressions for evaluation.
+
+At this point @SLIME{} is up and running and you can start exploring.
+
+You can restart the @code{inferior-lisp} process using the function:
+@table @kbd
+@cmditem{slime-restart-inferior-lisp}
+@end table
+
+@node Setup Tuning
+@section Setup Tuning
+
+This section explains ways to reduce @SLIME{}'s startup time and how
+to configure @SLIME{} for multiple Lisp systems.
+
+Please proceed with this section only if your basic setup works. If
+you are happy with the basic setup, skip this section.
+
+@menu
+* Autoloading::
+* Multiple Lisps::
+* Loading Swank faster::
+@end menu
+
+@node Autoloading
+@subsection Autoloading
+
+The basic setup loads @SLIME{} always, even if you don't use @SLIME{}.
+Emacs will start up a little faster if we load @SLIME{} only on
+demand. To achieve that, you have to change your @file{~/.emacs}
+slightly:
+
+@example
+(setq inferior-lisp-program "@emph{the path to your Lisp system}")
+(add-to-list 'load-path "@emph{the path of your @file{slime} directory}")
+(require 'slime-autoloads)
+(slime-setup)
+@end example
+
+The only difference compared to the basic setup is the line
+@code{(require 'slime-autoloads)}. It tells Emacs that the rest of
+@SLIME{} should be loaded automatically when one of the commands
+@kbd{M-x slime} or @kbd{M-x slime-connect} is executed the first time.
+
+@node Multiple Lisps
+@subsection Multiple Lisps
+
+By default, the command @kbd{M-x slime} starts the program specified
+with @code{inferior-lisp-program}. If you invoke @kbd{M-x slime} with
+a prefix argument, Emacs prompts for the program which should be
+started instead. If you need that frequently or if the command
+involves long filenames it's more convenient to set the
+@code{slime-lisp-implementations} variable in your @file{.emacs}. For
+example here we define two programs:
+
+@vindex slime-lisp-implementations
+@lisp
+(setq slime-lisp-implementations
+ '((cmucl ("cmucl" "-quiet"))
+ (sbcl ("/opt/sbcl/bin/sbcl") :coding-system utf-8-unix)))
+@end lisp
+
+This variable holds a list of programs and if you invoke @SLIME{} with
+a negative prefix argument, @kbd{M-- M-x slime}, you can select a
+program from that list. The elements of the list should look like
+
+@lisp
+(NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION)
+@end lisp
+
+@table @code
+@item NAME
+is a symbol and is used to identify the program.
+@item PROGRAM
+is the filename of the program. Note that the filename can contain
+spaces.
+@item PROGRAM-ARGS
+is a list of command line arguments.
+@item CODING-SYSTEM
+the coding system for the connection. (@pxref{slime-net-coding-system})
+@item INIT
+should be a function which takes two arguments: a filename and a
+character encoding. The function should return a Lisp expression as a
+string which instructs Lisp to start the Swank server and to write the
+port number to the file. At startup, @SLIME{} starts the Lisp process
+and sends the result of this function to Lisp's standard input. As
+default, @code{slime-init-command} is used. An example is shown in
+@ref{init-example,,Loading Swank faster}.
+@itemx INIT-FUNCTION
+should be a function which takes no arguments. It is called after
+the connection is established. (See also @ref{slime-connected-hook}.)
+@end table
+
+@node Loading Swank faster
+@subsection Loading Swank faster
+
+For SBCL, we recommend that you create a custom core file with socket
+support and @acronym{POSIX} bindings included because those modules
+take the most time to load. To create such a core, execute the
+following steps:
+
+@example
+shell$ sbcl
+* (mapc 'require '(sb-bsd-sockets sb-posix sb-introspect sb-cltl2 asdf))
+* (save-lisp-and-die "sbcl.core-for-slime")
+@end example
+
+After that, add something like this to your @file{.emacs}:
+
+@lisp
+(setq slime-lisp-implementations
+ '((sbcl ("sbcl" "--core" "sbcl.core-for-slime"))))
+@end lisp
+
+For maximum startup speed you can include the Swank server directly in
+a core file. The disadvantage of this approach is that the setup is a
+bit more involved and that you need to create a new core file when you
+want to update @SLIME{} or @acronym{SBCL}. The steps to execute are:
+
+@example
+shell$ sbcl
+* (load ".../slime/swank-loader.lisp")
+* (save-lisp-and-die "sbcl.core-with-swank")
+@end example
+
+@noindent
+Then add this to your @file{.emacs}:
+
+@anchor{init-example}
+@lisp
+(setq slime-lisp-implementations
+ '((sbcl ("sbcl" "--core" "sbcl.core-with-swank")
+ :init (lambda (port-file _)
+ (format "(swank:start-server %S)\n" port-file)))))
+@end lisp
+
+@noindent
+Similar setups should also work for other Lisp implementations.
+
+@node slime-mode
+@chapter Using slime-mode
+
+@SLIME{}'s commands are provided via @code{slime-mode}, a minor-mode
+used in conjunction with Emacs's @code{lisp-mode}. This chapter
+describes the @code{slime-mode} and its relatives.
+
+@menu
+* User-interface conventions::
+* Commands::
+* Semantic indentation::
+* Reader conditionals::
+@end menu
+
+@c -----------------------
+@node User-interface conventions
+@section User-interface conventions
+
+To use @SLIME{} comfortably it is important to understand a few
+``global'' user-interface characteristics. The most important
+principles are described in this section.
+
+@menu
+* Temporary buffers::
+* Inferior-lisp::
+* Multithreading::
+* Key bindings::
+@end menu
+
+@c -----------------------
+@node Temporary buffers
+@subsection Temporary buffers
+
+Some @SLIME{} commands create temporary buffers to display their
+results. Although these buffers usually have their own special-purpose
+major-modes, certain conventions are observed throughout.
+
+Temporary buffers can be dismissed by pressing @kbd{q}. This kills the
+buffer and restores the window configuration as it was before the
+buffer was displayed. Temporary buffers can also be killed with the
+usual commands like @code{kill-buffer}, in which case the previous
+window configuration won't be restored.
+
+Pressing @kbd{RET} is supposed to ``do the most obvious useful
+thing.'' For instance, in an apropos buffer this prints a full
+description of the symbol at point, and in an @acronym{XREF} buffer it
+displays the source code for the reference at point. This convention
+is inherited from Emacs's own buffers for apropos listings,
+compilation results, etc.
+
+Temporary buffers containing Lisp symbols use @code{slime-mode} in
+addition to any special mode of their own. This makes the usual
+@SLIME{} commands available for describing symbols, looking up
+function definitions, and so on.
+
+@c -----------------------
+@node Inferior-lisp
+@subsection @code{*inferior-lisp*} buffer
+
+@SLIME{} internally uses the @code{comint} package to start Lisp
+processes. This has a few user-visible consequences, some good and
+some not-so-terribly. To avoid confusion it is useful to understand
+the interactions.
+
+The buffer @code{*inferior-lisp*} contains the Lisp process's own
+top-level. This direct access to Lisp is useful for troubleshooting,
+and some degree of @SLIME{} integration is available using the
+@code{inferior-slime-mode}. However, in normal use we recommend using
+the fully-integrated @SLIME{} @REPL{} and ignoring the
+@code{*inferior-lisp*} buffer.
+
+@c -----------------------
+@node Multithreading
+@subsection Multithreading
+
+If the Lisp system supports multithreading, SLIME spawns a new thread
+for each request, e.g., @kbd{C-x C-e} creates a new thread to evaluate
+the expression. An exception to this rule are requests from the
+@REPL{}: all commands entered in the @REPL{} buffer are evaluated in a
+dedicated @REPL{} thread.
+
+Some complications arise with multithreading and special variables.
+Non-global special bindings are thread-local, e.g., changing the value
+of a let bound special variable in one thread has no effect on the
+binding of the variables with the same name in other threads. This
+makes it sometimes difficult to change the printer or reader behaviour
+for new threads. The variable
+@code{swank:*default-worker-thread-bindings*} was introduced for such
+situtuations: instead of modifying the global value of a variable, add a
+binding the @code{swank:*default-worker-thread-bindings*}. E.g., with
+the following code, new threads will read floating point values as
+doubles by default:
+
+@example
+(push '(*read-default-float-format* . double-float)
+ swank:*default-worker-thread-bindings*).
+@end example
+
+
+@node Key bindings
+@subsection Key bindings
+
+In general we try to make our key bindings fit with the overall Emacs
+style. We also have the following somewhat unusual convention of our
+own: when entering a three-key sequence, the final key can be pressed
+either with control or unmodified. For example, the
+@code{slime-describe-symbol} command is bound to @kbd{C-c C-d d}, but
+it also works to type @kbd{C-c C-d C-d}. We're simply binding both key
+sequences because some people like to hold control for all three keys
+and others don't, and with the two-key prefix we're not afraid of
+running out of keys.
+
+There is one exception to this rule, just to trip you up. We never
+bind @kbd{C-h} anywhere in a key sequence, so @kbd{C-c C-d C-h}
+doesn't do the same thing as @kbd{C-c C-d h}. This is because Emacs
+has a built-in default so that typing a prefix followed by @kbd{C-h}
+will display all bindings starting with that prefix, so @kbd{C-c C-d
+C-h} will actually list the bindings for all documentation commands.
+This feature is just a bit too useful to clobber!
+
+@quotation
+@i{``Are you deliberately spiting Emacs's brilliant online help facilities? The gods will be angry!''}
+@end quotation
+
+@noindent This is a brilliant piece of advice. The Emacs online help facilities
+are your most immediate, up-to-date and complete resource for keybinding
+information. They are your friends:
+
+@table @kbd
+@kbdanchorc{C-h k <key>, describe-key, ``What does this key do?''}
+Describes current function bound to @kbd{<key>} for focus buffer.
+
+@kbdanchorc{C-h b, describe-bindings, ``Exactly what bindings are available?''}
+Lists the current key-bindings for the focus buffer.
+
+@kbdanchorc{C-h m, describe-mode, ``Tell me all about this mode''}
+Shows all the available major mode keys, then the minor mode keys, for
+the modes of the focus buffer.
+
+@kbdanchorc{C-h l, view-lossage, ``Woah@comma{} what key chord did I just do?''}
+Shows you the literal sequence of keys you've pressed in order.
+
+@c <key> is breaks links PDF, despite that it's not l it's C-h
+@c @kbdanchorc{ <key> l, , ``What starts with?''}
+@c Lists all keybindings that begin with @code{<key>} for the focus buffer mode.
+
+
+@end table
+
+@emph{Note:} In this documentation the designation @kbd{C-h} is a
+@dfn{cannonical key} which might actually mean Ctrl-h, or F1, or
+whatever you have @code{help-command} bound to in your
+(a)code{.emacs}. Here is a common situation:
+
+@example
+(global-set-key [f1] 'help-command)
+(global-set-key "\C-h" 'delete-backward-char)
+@end example
+
+@noindent In this situation everywhere you see @kbd{C-h} in the
+documentation you would substitute @kbd{F1}.
+
+You can assign or change default key bindings globally using the
+@code{global-set-key} function in your @file{~/.emacs} file like this:
+@example
+(global-set-key "\C-c s" 'slime-selector)
+@end example
+@noindent
+which binds @kbd{C-c s} to the function @code{slime-selector}.
+
+Alternatively, if you want to assign or change a key binding in just a
+particular slime mode, you can use the @code{global-set-key} function
+in your @file{~/.emacs} file like this:
+@example
+(define-key slime-repl-mode-map (kbd "C-c ;")
+ 'slime-insert-balanced-comments)
+@end example
+@noindent
+which binds @kbd{C-c ;} to the function
+@code{slime-insert-balanced-comments} in the REPL buffer.
+
+@c -----------------------
+@node Commands
+@section Commands
+
+@acronym{SLIME} commands are divided into the following general
+categories: @strong{Programming, Compilation, Evaluation, Recovery,
+Inspector, and Profiling}, discussed in separate sections below. There
+are also comprehensive indices to commands by function
+(@pxref{Command Index}).
+
+@menu
+* Programming::
+* Compilation::
+* Evaluation::
+* Recovery::
+* Inspector::
+* Profiling::
+* Other::
+@end menu
+
+@c -----------------------
+@node Programming
+@subsection Programming commands
+
+Programming commands are divided into the following categories:
+@strong{Completion, Documentation, Cross-reference, Finding
+definitions, Macro-expansion, and Disassembly}, discussed in
+separate sections below.
+
+@menu
+* Completion::
+* Indentation::
+* Documentation::
+* Cross-reference::
+* Finding definitions::
+* Macro-expansion::
+* Disassembly::
+@end menu
+
+@c -----------------------
+@node Completion
+@subsubsection Completion commands
+
+@cindex Completion
+@cindex Symbol Completion
+
+Completion commands are used to complete a symbol or form based on
+what is already present at point. Classical completion assumes an
+exact prefix and gives choices only where branches may occur. Fuzzy
+completion tries harder.
+
+@table @kbd
+@kbditem{M-TAB,slime-complete-symbol}
+@itemx ESC TAB
+@itemx C-c C-i
+@itemx C-M-i
+Complete the symbol at point. Note that three styles of completion are
+available in @SLIME{}; the default is similar to normal Emacs
+completion (@pxref{slime-complete-symbol-function}).
+
+@end table
+
+@node Indentation
+@subsubsection Indentation commands
+
+@table @kbd
+
+@kbditem{C-M-q, indent-sexp}
+Indents the list immediately following point to match the level at point.
+
+When given a prefix argument, the text around point will always
+be treated as a paragraph. This is useful for filling docstrings."
+@end table
+
+@c -----------------------
+@node Documentation
+@subsubsection Documentation commands
+
+@SLIME{}'s online documentation commands follow the example of Emacs
+Lisp. The commands all share the common prefix @kbd{C-c C-d} and allow
+the final key to be modified or unmodified (@pxref{Key bindings}.)
+
+@table @kbd
+
+@kbditem{SPC, slime-space}
+The space key inserts a space, but also looks up and displays the
+argument list for the function at point, if there is one.
+
+@kbditem{C-c C-d d, slime-describe-symbol}
+Describe the symbol at point.
+
+@kbditem{C-c C-f, slime-describe-function}
+Describe the function at point.
+
+@kbditem{C-c C-d a, slime-apropos}
+Perform an apropos search on Lisp symbol names for a regular expression
+match and display their documentation strings. By default the external
+symbols of all packages are searched. With a prefix argument you can choose a
+specific package and whether to include unexported symbols.
+
+@kbditem{C-c C-d z, slime-apropos-all}
+Like @code{slime-apropos} but also includes internal symbols by default.
+
+@kbditem{C-c C-d p, slime-apropos-package}
+Show apropos results of all symbols in a package. This command is for
+browsing a package at a high-level. With package-name completion it
+also serves as a rudimentary Smalltalk-ish image-browser.
+
+@kbditem{C-c C-d h, slime-hyperspec-lookup}
+Lookup the symbol at point in the @cite{Common Lisp Hyperspec}. This
+uses the familiar @file{hyperspec.el} to show the appropriate section
+in a web browser. The Hyperspec is found either on the Web or in
+@code{common-lisp-hyperspec-root}, and the browser is selected by
+@code{browse-url-browser-function}.
+
+Note: this is one case where @kbd{C-c C-d h} is @emph{not} the same as
+@kbd{C-c C-d C-h}.
+
+@kbditem{C-c C-d ~, common-lisp-hyperspec-format}
+Lookup a @emph{format character} in the @cite{Common Lisp Hyperspec}.
+@end table
+
+
+@c -----------------------
+@node Cross-reference
+@subsubsection Cross-reference commands
+
+@cindex xref
+@cindex Cross-referencing
+
+@SLIME{}'s cross-reference commands are based on the support provided
+by the Lisp system, which varies widely between Lisps. For systems
+with no built-in @acronym{XREF} support @SLIME{} queries a portable
+@acronym{XREF} package, which is taken from the @cite{CMU AI
+Repository} and bundled with @SLIME{}.
+
+Each command operates on the symbol at point, or prompts if there is
+none. With a prefix argument they always prompt. You can either enter
+the key bindings as shown here or with the control modified on the
+last key, @xref{Key bindings}.
+
+@table @kbd
+@kbditem{C-c C-w c, slime-who-calls}
+Show function callers.
+
+@kbditem{C-c C-w w, slime-calls-who}
+Show all known callees.
+
+@kbditem{C-c C-w r, slime-who-references}
+Show references to global variable.
+
+@kbditem{C-c C-w b, slime-who-binds}
+Show bindings of a global variable.
+
+@kbditem{C-c C-w s, slime-who-sets}
+Show assignments to a global variable.
+
+@kbditem{C-c C-w m, slime-who-macroexpands}
+Show expansions of a macro.
+
+@cmditem{slime-who-specializes}
+Show all known methods specialized on a class.
+
+@end table
+
+There are also ``List callers/callees'' commands. These operate by
+rummaging through function objects on the heap at a low-level to
+discover the call graph. They are only available with some Lisp
+systems, and are most useful as a fallback when precise @acronym{XREF}
+information is unavailable.
+
+@table @kbd
+@kbditem{C-c <, slime-list-callers}
+List callers of a function.
+
+@kbditem{C-c >, slime-list-callees}
+List callees of a function.
+
+@end table
+
+
+
+@c -----------------------
+@node Finding definitions
+@subsubsection Finding definitions (``Meta-Point'' commands).
+
+@cindex Meta-dot
+@cindex TAGS
+
+The familiar @kbd{M-.} command is provided. For generic functions this
+command finds all methods, and with some systems it does other fancy
+things (like tracing structure accessors to their @code{DEFSTRUCT}
+definition).
+
+@table @kbd
+
+@kbditem{M-., slime-edit-definition}
+Go to the definition of the symbol at point.
+
+@item M-,
+@itemx M-*
+@itemx M-x slime-pop-find-definition-stack
+@kindex M-,
+@findex slime-pop-find-definition-stack
+Go back to the point where @kbd{M-.} was invoked. This gives multi-level
+backtracking when @kbd{M-.} has been used several times.
+
+@kbditem{C-x 4 ., slime-edit-definition-other-window}
+Like @code{slime-edit-definition} but switchs to the other window to
+edit the definition in.
+
+@kbditem{C-x 5 ., slime-edit-definition-other-frame}
+Like @code{slime-edit-definition} but opens another frame to edit the
+definition in.
+
+@cmditem{slime-edit-definition-with-etags}
+Use an ETAGS table to find definition at point.
+
+@end table
+
+@c -----------------------
+@node Macro-expansion
+@subsubsection Macro-expansion commands
+
+@cindex Macros
+
+@table @kbd
+@kbditem{C-c C-m, slime-macroexpand-1}
+Macroexpand the expression at point once. If invoked with a prefix
+argument, use macroexpand instead of macroexpand-1.
+
+@kbditem{C-c M-m, slime-macroexpand-all}
+Fully macroexpand the expression at point.
+
+@cmditem{slime-compiler-macroexpand-1}
+Display the compiler-macro expansion of sexp at point.
+
+@cmditem{slime-compiler-macroexpand}
+Repeatedy expamd compiler macros of sexp at point.
+
+@end table
+
+For additional minor-mode commands and discussion,
+@pxref{slime-macroexpansion-minor-mode}.
+
+
+@c -----------------------
+@node Disassembly
+@subsubsection Disassembly commands
+
+@table @kbd
+
+@kbditem{C-c M-d, slime-disassemble-symbol}
+Disassemble the function definition of the symbol at point.
+
+@kbditem{C-c C-t, slime-toggle-trace-fdefinition}
+Toggle tracing of the function at point. If invoked with a prefix
+argument, read additional information, like which particular method
+should be traced.
+
+@cmditem{slime-untrace-all}
+Untrace all functions.
+
+@end table
+
+@c -----------------------
+@node Compilation
+@subsection Compilation commands
+
+@cindex Compilation
+
+@SLIME{} has fancy commands for compiling functions, files, and
+packages. The fancy part is that notes and warnings offered by the
+Lisp compiler are intercepted and annotated directly onto the
+corresponding expressions in the Lisp source buffer. (Give it a try to
+see what this means.)
+
+@table @kbd
+@cindex Compiling Functions
+@kbditem{C-c C-c, slime-compile-defun}
+Compile the top-level form at point.
+
+@kbditem{C-c C-y, slime-call-defun}
+Insert a call to the function defined around point into the REPL.
+
+@kbditem{C-c C-k, slime-compile-and-load-file}
+Compile and load the current buffer's source file.
+
+@kbditem{C-c M-k, slime-compile-file}
+Compile (but don't load) the current buffer's source file.
+
+@kbditem{C-c C-l, slime-load-file}
+Load a source file and compile if necessary, without loading into a buffer..
+
+@kbditem{C-c C-z, slime-switch-to-output-buffer}
+Select the output buffer, preferably in a different window.
+
+@cmditem{slime-compile-region}
+Compile region at point.
+
+@end table
+
+The annotations are indicated as underlining on source forms. The
+compiler message associated with an annotation can be read either by
+placing the mouse over the text or with the selection commands below.
+
+@table @kbd
+@kbditem{M-n, slime-next-note}
+Move the point to the next compiler note and displays the note.
+
+@kbditem{M-p, slime-previous-note}
+Move the point to the previous compiler note and displays the note.
+
+@kbditem{C-c M-c, slime-remove-notes}
+Remove all annotations from the buffer.
+@end table
+
+@c -----------------------
+@node Evaluation
+@subsection Evaluation commands
+
+These commands each evaluate a Common Lisp expression in a different
+way. Usually they mimic commands for evaluating Emacs Lisp code. By
+default they show their results in the echo area, but a prefix
+argument causes the results to be inserted in the current buffer.
+
+@table @kbd
+
+@kbditem{C-x C-e, slime-eval-last-expression}
+
+Evaluate the expression before point and show the result in the echo
+area.
+
+@kbditem{C-M-x, slime-eval-defun}
+Evaluate the current toplevel form and show the result in the echo
+area. `C-M-x' treats `defvar' expressions specially. Normally,
+evaluating a `defvar' expression does nothing if the variable it
+defines already has a value. But `C-M-x' unconditionally resets the
+variable to the initial value specified in the `defvar' expression.
+This special feature is convenient for debugging Lisp programs.
+
+@end table
+
+If @kbd{C-M-x} or @kbd{C-x C-e} is given a numeric argument, it
+inserts the value into the current buffer, rather than displaying it
+in the echo area.
+
+@table @kbd
+@kbditem{C-c :, slime-interactive-eval}
+Evaluate an expression read from the minibuffer.
+
+@kbditem{C-c C-r, slime-eval-region}
+Evaluate the region.
+
+@kbditem{C-c C-p, slime-pprint-eval-last-expression}
+Evaluate the expression before point and pretty-print the result in a
+fresh buffer.
+
+@kbditem{C-c E, slime-edit-value}
+Edit the value of a setf-able form in a new buffer @file{*Edit <form>*}.
+The value is inserted into a temporary buffer for editing and then set
+in Lisp when committed with @kbd{C-c C-c}.
+
+@kbditem{C-x M-e, slime-eval-last-expression-display-output}
+Display the output buffer and evaluate the expression preceding point.
+This is useful if the expression writes something to the output stream.
+
+@kbditem{C-c C-u, slime-undefine-function}
+Undefine the function, with @code{fmakunbound}, for the symbol at
+point.
+
+@end table
+
+
+@c -----------------------
+@node Recovery
+@subsection Abort/Recovery commands
+
+@table @kbd
+@kbditem{C-c C-b, slime-interrupt}
+Interrupt Lisp (send @code{SIGINT}).
+
+@kbditem{C-c ~, slime-sync-package-and-default-directory}
+Synchronize the current package and working directory from Emacs to
+Lisp.
+
+@kbditem{C-c M-p, slime-repl-set-package}
+Set the current package of the @acronym{REPL}.
+
+@end table
+
+@c -----------------------
+@node Inspector
+@subsection Inspector commands
+
+The @SLIME{} inspector is a Emacs-based alternative to the
+standard @code{INSPECT} function. The inspector presents objects in
+Emacs buffers using a combination of plain text, hyperlinks to related
+objects.
+
+The inspector can easily be specialized for the objects in your own
+programs. For details see the the @code{inspect-for-emacs} generic
+function in @file{swank-backend.lisp}.
+
+@table @kbd
+
+@kbditem{C-c I, slime-inspect}
+Inspect the value of an expression entered in the minibuffer.
+
+@end table
+
+The standard commands available in the inspector are:
+
+@table @kbd
+
+@kbditem{RET, slime-inspector-operate-on-point}
+If point is on a value then recursivly call the inspcetor on that
+value. If point is on an action then call that action.
+
+@kbditem{d, slime-inspector-describe}
+Describe the slot at point.
+
+@kbditem{l, slime-inspector-pop}
+Go back to the previous object (return from @kbd{RET}).
+
+@kbditem{n, slime-inspector-next}
+The inverse of @kbd{l}. Also bound to @kbd{SPC}.
+
+@kbditem{q, slime-inspector-quit}
+Dismiss the inspector buffer.
+
+@kbditem{M-RET, slime-inspector-copy-down}
+Store the value under point in the variable `*'. This can
+then be used to access the object in the REPL.
+
+@end table
+
+@c -----------------------
+@node Profiling
+@subsection Profiling commands
+
+The profiling commands are based on CMUCL's profiler. These are
+simple wrappers around functions which usually print something to the
+output buffer.
+
+@table @kbd
+@cmditem{slime-toggle-profile-fdefinition}
+Toggle profiling of a function.
+@cmditem{slime-profile-package}
+Profile all functions in a package.
+@cmditem{slime-unprofile-all}
+Unprofile all functions.
+@cmditem{slime-profile-report}
+Report profiler data.
+@cmditem{slime-profile-reset}
+Reset profiler data.
+@cmditem{slime-profiled-functions}
+Show list of currently profiled functions.
+@end table
+
+@c -----------------------
+@node Other
+@subsection Shadowed Commands
+
+@table @kbd
+
+@kbditempair{C-c C-a, C-c C-v, slime-nop, slime-nop}
+This key-binding is shadowed from inf-lisp.
+
+@end table
+
+@c -----------------------
+@node Semantic indentation
+@section Semantic indentation
+
+@SLIME{} automatically discovers how to indent the macros in your Lisp
+system. To do this the Lisp side scans all the macros in the system and
+reports to Emacs all the ones with @code{&body} arguments. Emacs then
+indents these specially, putting the first arguments four spaces in and
+the ``body'' arguments just two spaces, as usual.
+
+This should ``just work.'' If you are a lucky sort of person you needn't
+read the rest of this section.
+
+To simplify the implementation, @SLIME{} doesn't distinguish between
+macros with the same symbol-name but different packages. This makes it
+fit nicely with Emacs's indentation code. However, if you do have
+several macros with the same symbol-name then they will all be indented
+the same way, arbitrarily using the style from one of their
+arglists. You can find out which symbols are involved in collisions
+with:
+
+@example
+(swank:print-indentation-lossage)
+@end example
+
+If a collision causes you irritation, don't have a nervous breakdown,
+just override the Elisp symbol's @code{common-lisp-indent-function}
+property to your taste. @SLIME{} won't override your custom settings, it
+just tries to give you good defaults.
+
+A more subtle issue is that imperfect caching is used for the sake of
+performance. @footnote{@emph{Of course} we made sure it was actually too
+slow before making the ugly optimization.}
+
+In an ideal world, Lisp would automatically scan every symbol for
+indentation changes after each command from Emacs. However, this is too
+expensive to do every time. Instead Lisp usually just scans the symbols
+whose home package matches the one used by the Emacs buffer where the
+request comes from. That is sufficient to pick up the indentation of
+most interactively-defined macros. To catch the rest we make a full scan
+of every symbol each time a new Lisp package is created between commands
+-- that takes care of things like new systems being loaded.
+
+You can use @kbd{M-x slime-update-indentation} to force all symbols to
+be scanned for indentation information.
+
+@c -----------------------
+@node Reader conditionals
+@section Reader conditional fontification
+
+@SLIME{} automatically evaluates reader-conditional expressions, like
+@code{#+linux}, in source buffers and ``grays out'' code that will be
+skipped for the current Lisp connection.
+
+
+@c -----------------------
+@node REPL
+@chapter REPL: the ``top level''
+
+@cindex Listener
+
+@SLIME{} uses a custom Read-Eval-Print Loop (@REPL{}, also known as a
+``top level'', or listener). The @REPL{} user-interface is written in
+Emacs Lisp, which gives more Emacs-integration than the traditional
+@code{comint}-based Lisp interaction:
+
+@itemize @bullet
+@item
+Conditions signalled in @REPL{} expressions are debugged with @SLDB{}.
+@item
+Return values are distinguished from printed output by separate Emacs
+faces (colours).
+@item
+Emacs manages the @REPL{} prompt with markers. This ensures that Lisp
+output is inserted in the right place, and doesn't get mixed up with
+user input.
+@end itemize
+
+@menu
+* REPL commands::
+* Input Navigation::
+* Shortcuts::
+@end menu
+
+@c -----------------------
+@node REPL commands
+@section REPL commands
+
+@table @kbd
+
+@kbditem{RET, slime-repl-return}
+Evaluate the current input in Lisp if it is complete. If incomplete,
+open a new line and indent. If a prefix argument is given then the
+input is evaluated without checking for completeness.
+
+@kbditem{C-RET, slime-repl-closing-return}
+Close any unmatched parenthesis and then evaluate the current input in
+Lisp. Also bound to @kbd{M-RET}.
+
+@kbditem{C-j, slime-repl-newline-and-indent}
+Open and indent a new line.
+
+@kbditem{C-a, slime-repl-bol}
+Go to the beginning of the line, but stop at the @REPL{} prompt.
+
+@c @anchor{slime-interrupt}
+@kbditem{C-c C-c, slime-interrupt}
+Interrupt the Lisp process with @code{SIGINT}.
+
+@c @kbditem{C-c M-g, slime-quit}
+@c Quit slime.
+
+@kbditem{C-c C-t, slime-repl-clear-buffer}
+Clear the entire buffer, leaving only a prompt.
+
+@kbditem{C-c C-o, slime-repl-clear-output}
+Remove the output and result of the previous expression from the
+buffer.
+
+@end table
+
+@c -----------------------
+@node Input Navigation
+@section Input navigation
+
+@cindex Input History
+
+The input navigation (a.k.a. history) commands are modelled after
+@code{coming}-mode. Be careful if you are used to Bash-like
+keybindings: @kbd{M-p} and @kbd{M-n} use the current input as search
+pattern and only work Bash-like if the current line is
+empty. @kbd{C-<up>} and @kbd{C-<up>} work like the up and down keys in
+Bash.
+
+@table @kbd
+
+@kbditempair{C-<up>, C-<down>,
+ slime-repl-forward-input, slime-repl-backward-input}
+Go to the next/previous history item.
+
+@kbditempair{M-n, M-p, slime-repl-next-input, slime-repl-previous-input}
+Search the next/previous item in the command history using the current
+input as search pattern. If @kbd{M-n}/@kbd{M-n} is typed two times in
+a row, the second invocation uses the same search pattern (even if the
+current input has changed).
+
+@kbditempair{M-s, M-r,
+slime-repl-next-matching-input, slime-repl-previous-matching-input}
+Search forward/reverse through command history with regex
+
+@c @code{slime-repl-@{next,previous@}-input}@*
+@c @code{slime-repl-@{next,previous@}-matching-input}@*
+@c @code{comint}-style input history commands.
+
+@kbditempair{C-c C-n, C-c C-p,
+slime-repl-next-prompt, slime-repl-previous-prompt}
+Move between the current and previous prompts in the @REPL{} buffer.
+Pressing RET on a line with old input copies that line to the newest
+prompt.
+@end table
+
+@vindex slime-repl-wrap-history
+The variable @code{slime-repl-wrap-history} controls wrap around
+behaviour, i.e. whether cycling should restart at the beginning of the
+history if the end is reached.
+
+@c -----------------------
+@comment node-name, next, previous, up
+@node Shortcuts
+@section Shortcuts
+
+@cindex Shortcuts
+
+``Shortcuts'' are a special set of @REPL{} commands that are invoked
+by name. To invoke a shortcut you first press @kbd{,} (comma) at the
+@REPL{} prompt and then enter the shortcut's name when prompted.
+
+Shortcuts deal with things like switching between directories and
+compiling and loading Lisp systems. The set of shortcuts is listed
+below, and you can also use the @code{help}
+shortcut to list them interactively.
+
+@table @kbd
+@item change-directory (aka !d, cd)
+Change the current directory.
+
+@item change-package (aka !p)
+Change the current package.
+
+@item compile-and-load (aka cl)
+Compile (if neccessary) and load a lisp file.
+
+
+@item defparameter (aka !)
+Define a new global, special, variable.
+
+@item help (aka ?)
+Display the help.
+
+
+
+@item pop-directory (aka -d)
+Pop the current directory.
+
+@item pop-package (aka -p)
+Pop the top of the package stack.
+
+@item push-directory (aka +d, pushd)
+Push a new directory onto the directory stack.
+
+@item push-package (aka +p)
+Push a package onto the package stack.
+
+@item pwd
+Show the current directory.
+
+@item quit
+Quit the current Lisp.
+
+@item resend-form
+Resend the last form.
+
+@item restart-inferior-lisp
+Restart *inferior-lisp* and reconnect SLIME.
+
+@item sayoonara
+Quit all Lisps and close all SLIME buffers.
+
+@end table
+
+@c -----------------------
+@node Debugger
+@chapter SLDB: the SLIME debugger
+
+@cindex Debugger
+
+@SLIME{} has a custom Emacs-based debugger called @SLDB{}. Conditions
+signalled in the Lisp system invoke @SLDB{} in Emacs by way of the
+Lisp @code{*DEBUGGER-HOOK*}.
+
+@SLDB{} pops up a buffer when a condition is signalled. The buffer
+displays a description of the condition, a list of restarts, and a
+backtrace. Commands are offered for invoking restarts, examining the
+backtrace, and poking around in stack frames.
+
+@menu
+* Examining frames::
+* Restarts::
+* Frame Navigation::
+* Stepping::
+* Miscellaneous::
+@end menu
+
+@c -----------------------
+@node Examining frames
+@section Examining frames
+
+Commands for examining the stack frame at point.
+
+@table @kbd
+@kbditem{t, sldb-toggle-details}
+Toggle display of local variables and @code{CATCH} tags.
+
+@kbditem{v, sldb-show-source}
+View the frame's current source expression. The expression is
+presented in the Lisp source file's buffer.
+
+@kbditem{e, sldb-eval-in-frame}
+Evaluate an expression in the frame. The expression can refer to the
+available local variables in the frame.
+
+@kbditem{d, sldb-pprint-eval-in-frame}
+Evaluate an expression in the frame and pretty-print the result in a
+temporary buffer.
+
+@kbditem{D, sldb-disassemble}
+Disassemble the frame's function. Includes information such as the
+instruction pointer within the frame.
+
+@kbditem{i, sldb-inspect-in-frame}
+Inspect the result of evaluating an expression in the frame.
+@end table
+
+@c -----------------------
+@node Restarts
+@section Invoking restarts
+
+@table @kbd
+@kbditem{a, sldb-abort}
+Invoke the @code{ABORT} restart.
+
+@kbditem{q, sldb-quit}
+``Quit'' -- @code{THROW} to a tag that the top-level @SLIME{}
+request-loop catches.
+
+@kbditem{c, sldb-continue}
+Invoke the @code{CONTINUE} restart.
+
+@item 0 ... 9
+Invoke a restart by number.
+@end table
+
+Restarts can also be invoked by pressing @kbd{RET} or @kbd{Mouse-2} on
+them in the buffer.
+
+@c -----------------------
+@node Frame Navigation
+@section Navigating between frames
+
+@table @kbd
+@kbditempair{n,p,sldb-down,sldb-up}
+Move between frames.
+
+@kbditempair{M-n, M-p, sldb-details-down, sldb-details-up}
+Move between frames ``with sugar'': hide the details of the original
+frame and display the details and source code of the next. Sugared
+motion makes you see the details and source code for the current frame
+only.
+@end table
+
+@node Stepping
+@section Stepping
+
+@cindex Stepping
+
+Stepping is not available in all implementations and works very
+differently in those in which it is available.
+
+@table @kbd
+@kbditem{s, sldb-step}
+Step to the next expression in the frame. For CMUCL that means, set a
+breakpoint at all those code locations in the current code block which
+are reachable from the current code location.
+
+@kbditem{x, sldb-next}
+[Step to the next form in the current function.]
+
+@kbditem{o, sldb-next}
+[Stop single-stepping temporarily, but resume it once the current
+function returns.]
+
+@end table
+
+@node Miscellaneous
+@section Miscellaneous Commands
+
+@table @kbd
+@kbditem{r, sldb-restart-frame}
+Restart execution of the frame with the same arguments it was
+originally called with. (This command is not available in all
+implementations.)
+
+@kbditem{R, sldb-return-from-frame}
+Return from the frame with a value entered in the minibuffer. (This
+command is not available in all implementations.)
+
+
+@kbditem{B, sldb-break-with-default-debugger}
+Exit @SLDB{} and debug the condition using the Lisp system's default
+debugger.
+
+@kbditem{:, slime-interactive-eval}
+Evaluate an expression entered in the minibuffer.
+@end table
+
+
+@c -----------------------
+@node Misc
+@chapter Misc
+
+@menu
+* slime-selector::
+* slime-macroexpansion-minor-mode::
+* Multiple connections::
+@end menu
+
+@c -----------------------
+@node slime-selector
+@section @code{slime-selector}
+
+The @code{slime-selector} command is for quickly switching to
+important buffers: the @REPL{}, @SLDB{}, the Lisp source you were just
+hacking, etc. Once invoked the command prompts for a single letter to
+specify which buffer it should display. Here are some of the options:
+
+@table @kbd
+@item ?
+A help buffer listing all @code{slime-selectors}'s available buffers.
+@item r
+The @REPL{} buffer for the current @SLIME{} connection.
+@item d
+The most recently activated @SLDB{} buffer for the current connection.
+@item l
+The most recently visited @code{lisp-mode} source buffer.
+@item s
+The @code{*slime-scratch*} buffer (@pxref{slime-scratch}).
+@end table
+
+@code{slime-selector} doesn't have a key binding by default but we
+suggest that you assign it a global one. You can bind it to @kbd{C-c s}
+like this:
+
+@example
+(global-set-key "\C-cs" 'slime-selector)
+@end example
+
+@noindent
+And then you can switch to the @REPL{} from anywhere with @kbd{C-c s
+r}.
+
+The macro @code{def-slime-selector-method} can be used to define new
+buffers for @code{slime-selector} to find.
+
+@c -----------------------
+@node slime-macroexpansion-minor-mode
+@section slime-macroexpansion-minor-mode
+
+Within a slime macroexpansion buffer some extra commands are provided
+(these commands are always available but are only bound to keys in a
+macroexpansion buffer).
+
+@table @kbd
+@kbditem{C-c C-m, slime-macroexpand-1-inplace}
+Just like slime-macroexpand-1 but the original form is replaced with
+the expansion.
+
+@c @anchor{slime-macroexpand-1-inplace}
+@kbditem{g, slime-macroexpand-1-inplace}
+The last macroexpansion is performed again, the current contents of
+the macroexpansion buffer are replaced with the new expansion.
+
+@kbditem{q, slime-temp-buffer-quit}
+Close the expansion buffer.
+
+@end table
+
+@c -----------------------
+@node Multiple connections
+@section Multiple connections
+
+@SLIME{} is able to connect to multiple Lisp processes at the same
+time. The @kbd{M-x slime} command, when invoked with a prefix
+argument, will offer to create an additional Lisp process if one is
+already running. This is often convenient, but it requires some
+understanding to make sure that your @SLIME{} commands execute in the
+Lisp that you expect them to.
+
+Some buffers are tied to specific Lisp processes. Each Lisp connection
+has its own @acronym{REPL} buffer, and all expressions entered or
+@SLIME{} commands invoked in that buffer are sent to the associated
+connection. Other buffers created by @SLIME{} are similarly tied to
+the connections they originate from, including @SLDB{} buffers,
+apropos result listings, and so on. These buffers are the result of
+some interaction with a Lisp process, so commands in them always go
+back to that same process.
+
+Commands executed in other places, such as @code{slime-mode} source
+buffers, always use the ``default'' connection. Usually this is the
+most recently established connection, but this can be reassigned via
+the ``connection list'' buffer:
+
+@table @kbd
+@kbditem{C-c C-x c, slime-list-connections}
+Pop up a buffer listing the established connections.
+
+@kbditem{C-c C-x t, slime-list-threads}
+Pop up a buffer listing the current threads.
+
+@end table
+
+The buffer displayed by @code{slime-list-connections} gives a one-line
+summary of each connection. The summary shows the connection's serial
+number, the name of the Lisp implementation, and other details of the
+Lisp process. The current ``default'' connection is indicated with an
+asterisk.
+
+The commands available in the connection-list buffer are:
+
+@table @kbd
+@kbditem{RET, slime-goto-connection}
+Pop to the @acronym{REPL} buffer of the connection at point.
+
+@kbditem{d, slime-connection-list-make-default}
+Make the connection at point the ``default'' connection. It will then
+be used for commands in @code{slime-mode} source buffers.
+
+@kbditem{g, slime-update-connection-list}
+Update the connection list in the buffer.
+
+@kbditem{q, slime-temp-buffer-quit}
+Quit the connection list (kill buffer, restore window configuration).
+
+@kbditem{R, slime-restart-connection-at-point}
+Restart the Lisp process for the connection at point.
+
+@cmditem{slime-connect}
+Connect to a running Swank server.
+
+@cmditem{slime-disconnect}
+Disconnect all connections.
+
+@cmditem{slime-abort-connection}
+Abort the current attempt to connect.
+
+@end table
+
+
+@c -----------------------
+@node Customization
+@chapter Customization
+
+@menu
+* Emacs-side customization::
+* Lisp-side::
+@end menu
+
+@c -----------------------
+@node Emacs-side customization
+@section Emacs-side
+
+The Emacs part of @SLIME{} can be configured with the Emacs
+@code{customize} system, just use @kbd{M-x customize-group slime
+RET}. Because the customize system is self-describing, we only cover a
+few important or obscure configuration options here in the manual.
+
+@table @code
+
+@item slime-truncate-lines
+The value to use for @code{truncate-lines} in line-by-line summary
+buffers popped up by @SLIME{}. This is @code{t} by default, which
+ensures that lines do not wrap in backtraces, apropos listings, and so
+on. It can however cause information to spill off the screen.
+
+@anchor{slime-complete-symbol-function}
+@vindex slime-complete-symbol-function
+@item slime-complete-symbol-function
+The function to use for completion of Lisp symbols. Three completion
+styles are available: @code{slime-simple-complete-symbol},
+@code{slime-complete-symbol*} (@pxref{Compound Completion}),
+and @code{slime-fuzzy-complete-symbol} (@pxref{Fuzzy Completion}).
+
+The default is @code{slime-simple-complete-symbol}, which completes in
+the usual Emacs way.
+
+@vindex slime-filename-translations
+@item slime-filename-translations
+This variable controls filename translation between Emacs and the Lisp
+system. It is useful if you run Emacs and Lisp on separate machines
+which don't share a common file system or if they share the filessytem
+but have different layouts, as is the case with @acronym{SMB}-based
+file sharing.
+
+@anchor{slime-net-coding-system}
+@vindex slime-net-coding-system
+@cindex Unicode
+@cindex UTF-8
+@cindex ASCII
+@cindex LATIN-1
+@cindex Character Encoding
+@item slime-net-coding-system
+If you want to transmit Unicode characters between Emacs and the Lisp
+system, you should customize this variable. E.g., if you use SBCL, you
+can set:
+@example
+(setq slime-net-coding-system 'utf-8-unix)
+@end example
+To actually display Unicode characters you also need appropriate
+fonts, otherwise the characters will be rendered as hollow boxes. If
+you are using Allegro CL and GNU Emacs, you can also
+use @code{emacs-mule-unix} as coding system. GNU Emacs has often
+nicer fonts for the latter encoding. (Different encodings can be used
+for different Lisps, see @ref{Multiple Lisps}.)
+
+@end table
+
+@menu
+* Hooks::
+@end menu
+
+@c -----------------------
+@node Hooks
+@subsection Hooks
+
+@table @code
+
+@vindex slime-mode-hook
+@item slime-mode-hook
+This hook is run each time a buffer enters @code{slime-mode}. It is
+most useful for setting buffer-local configuration in your Lisp source
+buffers. An example use is to enable @code{slime-autodoc-mode}
+(@pxref{slime-autodoc-mode}).
+
+@anchor{slime-connected-hook}
+@vindex slime-connected-hook
+@item slime-connected-hook
+This hook is run when @SLIME{} establishes a connection to a Lisp
+server. An example use is to create a Typeout frame (@xref{Typeout frames}.)
+
+@vindex sldb-hook
+@item sldb-hook
+This hook is run after @SLDB{} is invoked. The hook functions are
+called from the @SLDB{} buffer after it is initialized. An example use
+is to add @code{sldb-print-condition} to this hook, which makes all
+conditions debugged with @SLDB{} be recorded in the @REPL{} buffer.
+
+@end table
+
+@c -----------------------
+@node Lisp-side
+@section Lisp-side (Swank)
+
+The Lisp server side of @SLIME{} (known as ``Swank'') offers several
+variables to configure. The initialization file @file{~/.swank.lisp}
+is automatically evaluated at startup and can be used to set these
+variables.
+
+@menu
+* Communication style::
+* Other configurables::
+@end menu
+
+@c -----------------------
+@node Communication style
+@subsection Communication style
+@vindex SWANK:*COMMUNICATION-STYLE*
+
+The most important configurable is @code{SWANK:*COMMUNICATION-STYLE*},
+which specifies the mechanism by which Lisp reads and processes
+protocol messages from Emacs. The choice of communication style has a
+global influence on @SLIME{}'s operation.
+
+The available communication styles are:
+
+@table @code
+@item NIL
+This style simply loops reading input from the communication socket
+and serves @SLIME{} protocol events as they arise. The simplicity
+means that the Lisp cannot do any other processing while under
+@SLIME{}'s control.
+
+@item :FD-HANDLER
+This style uses the classical Unix-style ``@code{select()}-loop.''
+Swank registers the communication socket with an event-dispatching
+framework (such as @code{SERVE-EVENT} in @acronym{CMUCL} and
+@acronym{SBCL}) and receives a callback when data is available. In
+this style requests from Emacs are only detected and processed when
+Lisp enters the event-loop. This style is simple and predictable.
+
+@item :SIGIO
+This style uses @dfn{signal-driven I/O} with a @code{SIGIO} signal
+handler. Lisp receives requests from Emacs along with a signal,
+causing it to interrupt whatever it is doing to serve the
+request. This style has the advantage of responsiveness, since Emacs
+can perform operations in Lisp even while it is busy doing other
+things. It also allows Emacs to issue requests concurrently, e.g. to
+send one long-running request (like compilation) and then interrupt
+that with several short requests before it completes. The
+disadvantages are that it may conflict with other uses of @code{SIGIO}
+by Lisp code, and it may cause untold havoc by interrupting Lisp at an
+awkward moment.
+
+@item :SPAWN
+This style uses multiprocessing support in the Lisp system to execute
+each request in a separate thread. This style has similar properties
+to @code{:SIGIO}, but it does not use signals and all requests issued
+by Emacs can be executed in parallel.
+
+@end table
+
+The default request handling style is chosen according to the
+capabilities of your Lisp system. The general order of preference is
+@code{:SPAWN}, then @code{:SIGIO}, then @code{:FD-HANDLER}, with
+@code{NIL} as a last resort. You can check the default style by
+calling @code{SWANK-BACKEND:PREFERRED-COMMUNICATION-STYLE}. You can
+also override the default by setting
+@code{SWANK:*COMMUNICATION-STYLE*} in your Swank init file.
+
+@c -----------------------
+@node Other configurables
+@subsection Other configurables
+
+These Lisp variables can be configured via your @file{~/.swank.lisp}
+file:
+
+@table @code
+
+@vindex SWANK:*CONFIGURE-EMACS-INDENTATION*
+@item SWANK:*CONFIGURE-EMACS-INDENTATION*
+This variable controls whether indentation styles for
+@code{&body}-arguments in macros are discovered and sent to Emacs. It
+is enabled by default.
+
+@vindex SWANK:*GLOBALLY-REDIRECT-IO*
+@item SWANK:*GLOBALLY-REDIRECT-IO*
+When true this causes the standard streams (@code{*standard-output*},
+etc) to be globally redirected to the @REPL{} in Emacs. When
+@code{NIL} (the default) these streams are only temporarily redirected
+to Emacs using dynamic bindings while handling requests. Note that
+@code{*standard-input*} is currently never globally redirected into
+Emacs, because it can interact badly with the Lisp's native @REPL{} by
+having it try to read from the Emacs one.
+
+@vindex SWANK:*GLOBAL-DEBUGGER*
+@item SWANK:*GLOBAL-DEBUGGER*
+When true (the default) this causes @code{*DEBUGGER-HOOK*} to be
+globally set to @code{SWANK:SWANK-DEBUGGER-HOOK} and thus for @SLIME{}
+to handle all debugging in the Lisp image. This is for debugging
+multithreaded and callback-driven applications.
+
+@vindex SWANK:*SLDB-PRINTER-BINDINGS*
+@vindex SWANK:*MACROEXPAND-PRINTER-BINDINGS*
+@vindex SWANK:*SWANK-PPRINT-BINDINGS*
+@item SWANK:*SLDB-PRINTER-BINDINGS*
+@itemx SWANK:*MACROEXPAND-PRINTER-BINDINGS*
+@itemx SWANK:*SWANK-PPRINT-BINDINGS*
+These variables can be used to customize the printer in various
+situations. The values of the variables are association lists of
+printer variable names with the corresponding value. E.g., to enable
+the pretty printer for formatting backtraces in @SLDB{}, you can use:
+@example
+(push '(*print-pretty* . t) swank:*sldb-printer-bindings*).
+@end example
+
+@vindex SWANK:*USE-DEDICATED-OUTPUT-STREAM*
+@item SWANK:*USE-DEDICATED-OUTPUT-STREAM*
+This variable controls whether to use an unsafe efficiency hack for
+sending printed output from Lisp to Emacs. The default is @code{nil},
+don't use it, and is strongly recommended to keep.
+
+When @code{t}, a separate socket is established solely for Lisp to send
+printed output to Emacs through, which is faster than sending the output
+in protocol-messages to Emacs. However, as nothing can be guaranteed
+about the timing between the dedicated output stream and the stream of
+protocol messages, the output of a Lisp command can arrive before or
+after the corresponding REPL results. Thus output and REPL results can
+end up in the wrong order, or even interleaved, in the REPL buffer.
+Using a dedicated output stream also makes it more difficult to
+communicate to a Lisp running on a remote host via SSH
+(@pxref{Connecting to a remote lisp}).
+
+@vindex SWANK:*DEDICATED-OUTPUT-STREAM-PORT*
+@item SWANK:*DEDICATED-OUTPUT-STREAM-PORT*
+When @code{*USE-DEDICATED-OUTPUT-STREAM*} is @code{t} the stream will
+be opened on this port. The default value, @code{0}, means that the
+stream will be opened on some random port.
+
+@vindex SWANK:*LOG-EVENTS*
+@item SWANK:*LOG-EVENTS*
+Setting this variable to @code{t} causes all protocol messages
+exchanged with Emacs to be printed to @code{*TERMINAL-IO*}. This is
+useful for low-level debugging and for observing how @SLIME{} works
+``on the wire.'' The output of @code{*TERMINAL-IO*} can be found in
+your Lisp system's own listener, usually in the buffer
+@code{*inferior-lisp*}.
+
+@end table
+
+@c -----------------------
+@node Tips and Tricks
+@chapter Tips and Tricks
+
+@menu
+* Connecting to a remote lisp::
+* Global IO Redirection::
+* Auto-SLIME::
+@end menu
+
+@c -----------------------
+@node Connecting to a remote lisp
+@section Connecting to a remote lisp
+
+One of the advantages of the way @SLIME{} is implemented is that we
+can easily run the Emacs side (slime.el) on one machine and the lisp
+backend (swank) on another. The basic idea is to start up lisp on the
+remote machine, load swank and wait for incoming slime connections. On
+the local machine we start up emacs and tell slime to connect to the
+remote machine. The details are a bit messier but the underlying idea
+is that simple.
+
+@menu
+* Setting up the lisp image::
+* Setting up Emacs::
+* Setting up pathname translations::
+@end menu
+
+@c -----------------------
+@node Setting up the lisp image
+@subsection Setting up the lisp image
+
+
+When you want to load swank without going through the normal, Emacs
+based, process just load the @file{swank-loader.lisp} file. Just
+execute
+
+@example
+(load "/path/to/swank-loader.lisp")
+@end example
+
+inside a running lisp image@footnote{@SLIME{} also provides an
+@acronym{ASDF} system definiton which does the same thing}. Now all we
+need to do is startup our swank server. The first example assumes we're
+using the default settings.
+
+@example
+(swank:create-server)
+@end example
+
+Since we're going to be tunneling our connection via
+ssh@footnote{there is a way to connect without an ssh tunnel, but it
+has the side-effect of giving the entire world access to your lisp
+image, so we're not going to talk about it} and we'll only have one
+port open we want to tell swank to not use an extra connection for
+output (this is actually the default in current SLIME):
+
+@example
+(setf swank:*use-dedicated-output-stream* nil)
+@end example
+
+@c -----------------------
+If you need to do anything particular
+(like be able to reconnect to swank after you're done), look into
+@code{swank:create-server}'s other arguments. Some of these arguments
+are
+@table @code
+
+@item :PORT
+Port number for the server to listen on (default: 4005).
+@item :STYLE
+See @xref{Communication style}.
+@item :DONT-CLOSE
+Boolean indicating if the server will continue to accept connections
+after the first one (default: @code{NIL}). For ``long-running'' lisp processes
+to which you want to be able to connect from time to time,
+specify @code{:dont-close t}
+@item :CODING-SYSTEM
+String designating the encoding to be used to communicate between the
+Emacs and Lisp.
+@end table
+
+So the more complete example will be
+@example
+(swank:create-server :port 4005 :dont-close t :coding-system "utf-8-unix")
+@end example
+On the emacs side you will use something like
+@example
+(setq slime-net-coding-system 'utf-8-unix)
+(slime-connect "127.0.0.1" 4005))
+@end example
+to connect to this lisp image from the same machine.
+
+
+@node Setting up Emacs
+@subsection Setting up Emacs
+
+Now we need to create the tunnel between the local machine and the
+remote machine.
+
+@example
+ssh -L4005:127.0.0.1:4005 username@@remote.example.com
+@end example
+
+That ssh invocation creates an ssh tunnel between the port 4005 on our
+local machine and the port 4005 on the remote machine@footnote{By
+default swank listens for incoming connections on port 4005, had we
+passed a @code{:port} parameter to @code{swank:create-server} we'd be
+using that port number instead}.
+
+Finally we can start @SLIME{}:
+
+@example
+M-x slime-connect RET RET
+@end example
+
+The @kbd{RET RET} sequence just means that we want to use the default
+host (@code{127.0.0.1}) and the default port (@code{4005}). Even
+though we're connecting to a remote machine the ssh tunnel fools Emacs
+into thinking it's actually @code{127.0.0.1}.
+
+@c -----------------------
+@node Setting up pathname translations
+@subsection Setting up pathname translations
+
+One of the main problems with running swank remotely is that Emacs
+assumes the files can be found using normal filenames. if we want
+things like @code{slime-compile-and-load-file} (@kbd{C-c C-k}) and
+@code{slime-edit-definition} (@kbd{M-.}) to work correctly we need to
+find a way to let our local Emacs refer to remote files.
+
+There are, mainly, two ways to do this. The first is to mount, using
+NFS or similar, the remote machine's hard disk on the local machine's
+file system in such a fashion that a filename like
+(a)file{/opt/project/source.lisp} refers to the same file on both
+machines. Unfortunetly NFS is usually slow, often buggy, and not
+always feasable, fortunetely we have an ssh connection and Emacs'
+@code{tramp-mode} can do the rest.
+(See @inforef{Top, TRAMP User Manual,tramp}.)
+
+What we do is teach Emacs how to take a filename on the remote machine
+and translate it into something that tramp can understand and access
+(and vice-versa). Assuming the remote machine's host name is
+(a)code{remote.example.com}, @code{cl:machine-instance} returns
+``remote'' and we login as the user ``user'' we can use @SLIME{}'s
+built-in mechanism to setup the proper transaltions by simply doing:
+
+@example
+(push (slime-create-filename-translator :machine-instance "remote.example.com"
+ :remote-host "remote"
+ :username "user")
+ slime-filename-translations)
+@end example
+
+@c -----------------------
+@node Global IO Redirection
+@section Globally redirecting all IO to the REPL
+
+By default @SLIME{} does not change @code{*standard-output*} and
+friends outside of the @REPL{}. If you have any other threads which
+call @code{format}, @code{write-string}, etc. that output will be seen
+only in the @code{*inferior-lisp*} buffer or on the terminal, more
+often than not this is inconvenient. So, if you want code such as this:
+
+@example
+(run-in-new-thread
+ (lambda ()
+ (write-line "In some random thread.~%" *standard-output*)))
+@end example
+
+to send its output to @SLIME{}'s repl buffer, as opposed to
+@code{*inferior-lisp*}, set @code{swank:*globally-redirect-io*} to T.
+
+Note that the value of this variable is only checked when swank
+accepts the connection so you should set it via
+(a)file{~/.swank.lisp}. Otherwise you will need to call
+@code{swank::globally-redirect-io-to-connection} yourself, but you
+shouldn't do that unless you know what you're doing.
+
+@c -----------------------
+@node Auto-SLIME
+@section Connecting to SLIME automatically
+
+To make @SLIME{} connect to your lisp whenever you open a lisp file
+just add this to your @file{.emacs}:
+
+@example
+(add-hook 'slime-mode-hook
+ (lambda ()
+ (unless (slime-connected-p)
+ (save-excursion (slime)))))
+@end example
+
+@node Contributed Packages
+@chapter Contributed Packages
+
+In version 3.0 we moved some functionility to separate packages. This
+chapter tells you how to load contrib modules and describes what the
+particular packages do.
+
+@menu
+* Loading Contribs::
+* Compound Completion::
+* Fuzzy Completion::
+* slime-autodoc-mode::
+* ASDF::
+* Banner::
+* Editing Commands::
+* Fancy Inspector::
+* Presentations::
+* Typeout frames::
+* TRAMP::
+* Documentation Links::
+* Xref and Class Browser::
+* Highlight Edits::
+* inferior-slime-mode::
+* Scratch Buffer::
+* slime-fancy::
+@end menu
+
+@node Loading Contribs
+@section Loading Contrib Packages
+
+@cindex Contribs
+@cindex Contributions
+@cindex Plugins
+
+Contrib packages aren't loaded by default. You have to modify your
+setup a bit so that Emacs knows where to find them and which of them
+to load, i.e. you should add the contrib directory to
+Emacs' @code{load-path} and call @code{slime-setup} with the list of
+package-names. For example, a setup to load the @code{slime-scratch}
+and @code{slime-editing-commands} looks like:
+
+@example
+(add-to-list 'load-path ".../slime") ; path for core
+(add-to-list 'load-path ".../slime/contrib") ; path for contribs
+(require 'slime-autoloads)
+(slime-setup '(slime-scratch slime-editing-commands))
+@end example
+
+After starting SLIME, the commands of both packages should be
+available.
+
+@node Compound Completion
+@section Compund Completion
+
+@anchor{slime-complete-symbol*}
+The package @code{slime-c-p-c} provides a different symbol completion
+algorithm, which performs completion ``in parallel'' over the
+hyphen-delimited sub-words of a symbol name.
+@footnote{This style of completion is modelled on @file{completer.el}
+by Chris McConnell. That package is bundled with @acronym{ILISP}.}
+Formally this means that ``@code{a-b-c}'' can complete to any symbol
+matching the regular expression ``(a)code{^a.*-b.*-c.*}'' (where ``dot''
+matches anything but a hyphen). Examples give a more intuitive
+feeling:
+@itemize @bullet
+@item
+@code{m-v-b} completes to @code{multiple-value-bind}.
+@item
+@code{w-open} is ambiguous: it completes to either
+@code{with-open-file} or @code{with-open-stream}. The symbol is
+expanded to the longest common completion (@code{with-open-}) and the
+point is placed at the first point of ambiguity, which in this case is
+the end.
+@item
+@code{w--stream} completes to @code{with-open-stream}.
+@end itemize
+
+The variable @code{slime-c-p-c-unambiguous-prefix-p} specifies where
+point should be placed after completion. E.g. the possible
+completions for @code{f-o} are @code{finish-output} and
+@code{force-output}. By the default point is moved after the
+@code{f}, because that is the unambigous prefix. If
+@code{slime-c-p-c-unambiguous-prefix-p} is nil, point moves to
+the end of the inserted text, after the @code{o} in this case.
+
+@table @kbd
+@kbditem{C-c C-s, slime-complete-form}
+Looks up and inserts into the current buffer the argument list for the
+function at point, if there is one. More generally, the command
+completes an incomplete form with a template for the missing arguments.
+There is special code for discovering extra keywords of generic
+functions and for handling @code{make-instance} and
+@code{defmethod}. Examples:
+
+@example
+(subseq "abc" <C-c C-s>
+ --inserts--> start [end])
+(find 17 <C-c C-s>
+ --inserts--> sequence :from-end from-end :test test
+ :test-not test-not :start start :end end
+ :key key)
+(find 17 '(17 18 19) :test #'= <C-c C-s>
+ --inserts--> :from-end from-end
+ :test-not test-not :start start :end end
+ :key key)
+(defclass foo () ((bar :initarg :bar)))
+(defmethod print-object <C-c C-s>
+ --inserts--> (object stream)
+ body...)
+(defmethod initialize-instance :after ((object foo) &key blub))
+(make-instance 'foo <C-c C-s>
+ --inserts--> :bar bar :blub blub initargs...)
+@end example
+@end table
+
+@node Fuzzy Completion
+@section Fuzzy Completion
+
+The package @code{slime-fuzzy} implements yet another symbol
+completion heuristic.
+
+[Somebody please describe what the algorithm actually does]
+
+It attempts to complete a symbol all at once, instead of in pieces.
+For example, ``mvb'' will find ``@code{multiple-value-bind}'' and
+``norm-df'' will find
+``@code{least-positive-normalized-double-float}''.
+
+The algorithm tries to expand every character in various ways and
+rates the list of possible completions with the following heuristic.
+
+Letters are given scores based on their position in the string.
+Letters at the beginning of a string or after a prefix letter at
+the beginning of a string are scored highest. Letters after a
+word separator such as #\- are scored next highest. Letters at
+the end of a string or before a suffix letter at the end of a
+string are scored medium, and letters anywhere else are scored
+low.
+
+If a letter is directly after another matched letter, and its
+intrinsic value in that position is less than a percentage of the
+previous letter's value, it will use that percentage instead.
+
+Finally, a small scaling factor is applied to favor shorter
+matches, all other things being equal.
+
+@table @kbd
+@anchor{slime-fuzzy-complete-symbol}
+@kbditem{C-c M-i, slime-fuzzy-complete-symbol}
+Presents a list of likely completions to choose from for an
+abbreviation at point. If you set the
+variable @code{slime-complete-symbol-function} to this command, fuzzy
+completion will also be used for @kbd{M-TAB}.
+@end table
+
+@node slime-autodoc-mode
+@section @code{slime-autodoc-mode}
+
+Autodoc mode is an additional minor-mode for automatically showing
+information about symbols near the point. For function names the
+argument list is displayed, and for global variables, the value.
+This is a clone of @code{eldoc-mode} for Emacs Lisp.
+
+The mode can be enabled by default in the @code{slime-setup} call of your
+(a)code{~/.emacs}:
+@example
+(slime-setup '(slime-autodoc))
+@end example
+
+@table @kbd
+@cmditem{slime-arglist NAME}
+Show the argument list of the function NAME.
+
+@cmditem{slime-autodoc-mode}
+Toggles autodoc-mode on or off according to the argument, and
+toggles the mode when invoked without argument.
+@end table
+
+If the variable @code{slime-use-autodoc-mode} is set (default), Emacs
+starts a timer, otherwise the information is only displayed after
+pressing SPC.
+
+@node ASDF
+@section ASDF
+
+@acronym{ASDF} is a popular ``system construction tool''. The package
+@code{slime-asdf} provides some commands to load and compile such
+systems from Emacs. @acronym{ASDF} itself is not included with
+@SLIME{}; you have to load that yourself into your Lisp. In
+particular, you must load @acronym{ASDF} before you connect, otherwise
+you will get errors about missing symbols.
+
+@table @kbd
+@cmditem{slime-load-system NAME}
+Compile and load an ASDF system. The default system name is taken
+from the first file matching *.asd in the current directory.
+@end table
+
+The package also installs some new REPL shortcuts (@pxref{Shortcuts}):
+
+@table @kbd
+@item load-system
+Compile (as needed) and load an ASDF system.
+@item compile-system
+Compile (but not load) an ASDF system.
+@item force-compile-system
+Recompile (but not load) an ASDF system.
+@item force-load-system
+Recompile and load an ASDF system.
+@end table
+
+@node Banner
+@section Banner
+The package @code{slime-banner} installs a window header line (
+@inforef{Header Lines, , elisp}.) in the REPL buffer. It also runs an
+animation at startup.
+
+@vindex slime-startup-animation
+@vindex slime-header-line-p
+By setting the variable @code{slime-startup-animation} to nil you can
+disable the animation respectivly with the
+variable @code{slime-header-line-p} the header line.
+
+@node Editing Commands
+@section Editing Commands
+
+The package @code{slime-editing-commands} provides some commands to
+edit Lisp expressions.
+
+@table @kbd
+@kbditem{C-c M-q, slime-reindent-defun}
+Re-indents the current defun, or refills the current paragraph.
+If point is inside a comment block, the text around point will be
+treated as a paragraph and will be filled with @code{fill-paragraph}.
+Otherwise, it will be treated as Lisp code, and the current defun
+will be reindented. If the current defun has unbalanced parens,
+an attempt will be made to fix it before reindenting.
+
+@cmditem{slime-close-all-parens-in-sexp}
+Balance parentheses of open s-expressions at point.
+Insert enough right parentheses to balance unmatched left parentheses.
+Delete extra left parentheses. Reformat trailing parentheses
+Lisp-stylishly.
+
+If REGION is true, operate on the region. Otherwise operate on
+the top-level sexp before point.
+
+@cmditem{slime-insert-balanced-comments}
+Insert a set of balanced comments around the s-expression containing
+the point. If this command is invoked repeatedly (without any other
+command occurring between invocations), the comment progressively
+moves outward over enclosing expressions. If invoked with a positive
+prefix argument, the s-expression arg expressions out is enclosed in a
+set of balanced comments.
+
+@kbditem{M-C-a, slime-beginning-of-defun}
+@kbditem{M-C-e, slime-end-of-defun}
+@end table
+
+@node Fancy Inspector
+@section Fancy Inspector
+
+@cindex Methods
+
+An alternative to default inspector is provided by the package
+`slime-fancy-inspector'. This inspector knows a lot about CLOS
+objects and methods. It provides many ``actions'' that can be
+selected to invoke Lisp code on the inspected object. For example, to
+present a generic function the inspector shows the documentation in
+plain text and presents each method with both a hyperlink to inspect
+the method object and a ``remove method'' action that you can invoke
+interactively. The key-bindings are the same as for the basic
+inspector (@pxref{Inspector}).
+
+@node Presentations
+@section Presentations
+
+@cindex Presentations
+
+A ``presentation''@footnote{Presentations are a feature originating
+from the Lisp machines. It was possible to define @code{present}
+methods specialized to various devices, e.g. to draw an object to
+bitmapped screen or to write some text to a character stream.} in
+@SLIME{} is a region of text associated with a Lisp object.
+Right-clicking on the text brings up a menu with operations for the
+particular object. Some operations, like inspecting, are available
+for all objects, but the object may also have specialized operations.
+E.g. pathnames have a dired operation.
+
+The package @code{slime-presentations} installs presentations in the
+REPL, i.e. the results of evaluation commands become presentations.
+
+For some implementations you can also install
+@code{slime-presentation-streams} which enables presentations on the
+Lisp @code{*standard-output*} stream. E.g. printing a list to such a
+stream will create presentions in the Emacs buffer.
+
+@table @kbd
+@cmditem{slime-copy-or-inspect-presentation-at-mouse}
+@cmditem{slime-inspect-presentation-at-mouse}
+@cmditem{slime-copy-presentation-at-mouse}
+@cmditem{slime-copy-presentation-at-mouse-to-point}
+@cmditem{slime-copy-presentation-at-mouse-to-kill-ring}
+@cmditem{slime-describe-presentation-at-mouse}
+@cmditem{slime-pretty-print-presentation-at-mouse}
+@cmditem{slime-clear-presentations}
+@end table
+
+@node Typeout frames
+@section Typeout frames
+
+@cindex Typeout Frame
+
+A ``typeout frame'' is a special Emacs frame which is used instead of
+the echo area (minibuffer) to display messages from @SLIME{} commands.
+This is an optional feature. The advantage of a typeout frame over the
+echo area is that it can hold more text, it can be scrolled, and its
+contents don't disappear when you press a key. All potentially long
+messages are sent to the typeout frame, such as argument lists, macro
+expansions, and so on.
+
+@table @kbd
+@cmditem{slime-ensure-typeout-frame}
+Ensure that a typeout frame exists, creating one if necessary.
+@end table
+
+If the typeout frame is closed then the echo area will be used again
+as usual.
+
+To have a typeout frame created automatically at startup you should
+load the @code{slime-typeout-frame} package. (@pxref{Loading Contribs}.)
+
+The variable @code{slime-typeout-frame-properties} specifies the
+height and possibly other properties of the frame. Its value is
+passed to @code{make-frame}. (@inforef{Creating Frames, ,elisp}.)
+
+@node TRAMP
+@section TRAMP
+
+@cindex TRAMP
+
+The package @code{slime-tramp} provides some functions to set up
+filename translations for TRAMP. (@pxref{Setting up pathname
+translations})
+
+@node Documentation Links
+@section Documentation Links
+
+For certain error messages, SBCL includes references to the ANSI
+Standard or the SBCL User Manual. The @code{slime-references} package
+turns those references into clickable links. This makes finding the
+referenced section of the HyperSpec much easier.
+
+@node Xref and Class Browser
+@section Xref and Class Browser
+
+A rudimentary class browser is provied by
+the @code{slime-xref-browser} package.
+
+@table @kbd
+@cmditem{slime-browse-classes}
+This command asks for a class name and displays inheritance tree of
+for the class.
+
+@cmditem{slime-browse-xrefs}
+This command prompts for a symbol and the kind of cross reference,
+e.g. callers. The cross reference tree rooted at the symbol is then
+then displayed.
+
+@end table
+
+
+@node Highlight Edits
+@section Highlight Edits
+
+@code{slime-highlight-edits} is a minor mode to highlight those
+regions in a Lisp source file which are modified. This is useful to
+quickly find those functions which need to be recompiled (whith
+@kbd{C-c C-c})
+
+@table @kbd
+@cmditem{slime-highlight-edits-mode}
+Turns @code{slime-highlight-edits-mode} on or off.
+@end table
+
+@node inferior-slime-mode
+@section @code{inferior-slime-mode}
+
+The @code{inferior-slime-mode} is a minor mode is intended to use with
+a comint buffer. It provides some of the SLIME commands, like symbol
+completion and documentation lookup. To install it, add something
+like this to user @file{.emacs}:
+
+@example
+(slime-setup '(inferior-slime-mode))
+(add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1)))
+@end example
+
+@table @kbd
+@cmditem{inferior-slime-mode}
+Turns inferior-slime-mode on or off.
+@end table
+
+@vindex inferior-slime-mode-map
+The variable @code{inferior-slime-mode-map} contains the extra
+keybindings.
+
+@node Scratch Buffer
+@section Scratch Buffer
+
+@anchor{slime-scratch}
+The @SLIME{} scratch buffer, in contrib package @code{slime-scratch},
+imitates Emacs' usual @code{*scratch*} buffer. It's just like any
+other Lisp buffer, except for the command bound to @kbd{C-j}.
+
+@table @kbd
+
+@kbditem{C-j, slime-eval-print-last-expression}
+Evaluate the expression sexp before point and insert print value into
+the current buffer.
+
+@cmditem{slime-scratch}
+Create a @file{*slime-scratch*} buffer. In this
+buffer you can enter Lisp expressions and evaluate them with
+@kbd{C-j}, like in Emacs's @file{*scratch*} buffer.
+
+@end table
+
+@node slime-fancy
+@section Meta package: @code{slime-fancy}
+
+@code{slime-fancy} is a meta package which loads a combination of the
+most popular packages.
+
+@c -----------------------
+@node Credits
+@chapter Credits
+
+@emph{The soppy ending...}
+
+@unnumberedsec Hackers of the good hack
+
+@SLIME{} is an Extension of @acronym{SLIM} by Eric Marsden. At the
+time of writing, the authors and code-contributors of @SLIME{} are:
+
+@include contributors.texi
+
+... not counting the bundled code from @file{hyperspec.el},
+@cite{CLOCC}, and the @cite{CMU AI Repository}.
+
+Many people on the @code{slime-devel} mailing list have made non-code
+contributions to @SLIME{}. Life is hard though: you gotta send code to
+get your name in the manual. @code{:-)}
+
+@unnumberedsec Thanks!
+
+We're indebted to the good people of @code{common-lisp.net} for their
+hosting and help, and for rescuing us from ``Sourceforge hell.''
+
+Implementors of the Lisps that we support have been a great help. We'd
+like to thank the @acronym{CMUCL} maintainers for their helpful
+answers, Craig Norvell and Kevin Layer at Franz providing Allegro CL
+licenses for @SLIME{} development, and Peter Graves for his help to
+get @SLIME{} running with @acronym{ABCL}.
+
+Most of all we're happy to be working with the Lisp implementors
+who've joined in the @SLIME{} development: Dan Barlow and Christophe
+Rhodes of @acronym{SBCL}, Gary Byers of OpenMCL, and Martin Simmons of
+LispWorks. Thanks also to Alain Picard and Memetrics for funding
+Martin's initial work on the LispWorks backend!
+
+@ignore
+This index is currently ingored, because texinfo's built-in indexing
+produces nicer results. -- Helmut Eller
+
+@c@node Index to Functions
+@c@appendix Index to Functions
+
+These functions are all available (when relevant). To find the
+keybinding (if there is one) refer to the function description.
+
+@c Note to editors: @fcnindex{...} lines commented out below are place holders
+@c ----------------
+@c They have yet to be documented
+@c Please feel free to add descriptions in the text where appropriate, add the
+@c appropriate anchors and uncomment them.
+@c
+@c [jkc]
+
+@table @code
+@fcnindex{common-lisp-hyperspec-format}
+@fcnindex{sldb-abort}
+@c @fcnindex{sldb-activate}
+@c @fcnindex{sldb-add-face}
+@c @fcnindex{sldb-backward-frame}
+@c @fcnindex{sldb-beginning-of-backtrace}
+@c @fcnindex{sldb-break}
+@c @fcnindex{sldb-break-on-return}
+@fcnindex{sldb-break-with-default-debugger}
+@c @fcnindex{sldb-buffers}
+@c @fcnindex{sldb-catch-tags}
+@fcnindex{sldb-continue}
+@c @fcnindex{sldb-debugged-continuations}
+@c @fcnindex{sldb-default-action}
+@c @fcnindex{sldb-default-action/mouse}
+@c @fcnindex{sldb-delete-overlays}
+@c @fcnindex{sldb-details-down}
+@c @fcnindex{sldb-details-up}
+@fcnindex{sldb-disassemble}
+@c @fcnindex{sldb-dispatch-extras}
+@c @fcnindex{sldb-down}
+@c @fcnindex{sldb-end-of-backtrace}
+@fcnindex{sldb-eval-in-frame}
+@c @fcnindex{sldb-exit}
+@c @fcnindex{sldb-fetch-all-frames}
+@c @fcnindex{sldb-fetch-more-frames}
+@c @fcnindex{sldb-find-buffer}
+@c @fcnindex{sldb-format-reference-node}
+@c @fcnindex{sldb-format-reference-source}
+@c @fcnindex{sldb-forward-frame}
+@c @fcnindex{sldb-frame-details-visible-p}
+@c @fcnindex{sldb-frame-locals}
+@c @fcnindex{sldb-frame-number-at-point}
+@c @fcnindex{sldb-frame-region}
+@c @fcnindex{sldb-get-buffer}
+@c @fcnindex{sldb-get-default-buffer}
+@c @fcnindex{sldb-goto-last-frame}
+@c @fcnindex{sldb-help-summary}
+@c @fcnindex{sldb-hide-frame-details}
+@c @fcnindex{sldb-highlight-sexp}
+@c @fcnindex{sldb-insert-condition}
+@c @fcnindex{sldb-insert-frame}
+@c @fcnindex{sldb-insert-frames}
+@c @fcnindex{sldb-insert-locals}
+@c @fcnindex{sldb-insert-references}
+@c @fcnindex{sldb-insert-restarts}
+@c @fcnindex{sldb-inspect-condition}
+@fcnindex{sldb-inspect-in-frame}
+@c @fcnindex{sldb-inspect-var}
+@c @fcnindex{sldb-invoke-restart}
+@c @fcnindex{sldb-level}
+@c @fcnindex{sldb-list-catch-tags}
+@c @fcnindex{sldb-list-locals}
+@c @fcnindex{sldb-lookup-reference}
+@c @fcnindex{sldb-maybe-recenter-region}
+@c @fcnindex{sldb-mode-hook}
+@c @fcnindex{sldb-next}
+@c @fcnindex{sldb-out}
+@fcnindex{sldb-pprint-eval-in-frame}
+@c @fcnindex{sldb-previous-frame-number}
+@c @fcnindex{sldb-print-condition}
+@c @fcnindex{sldb-prune-initial-frames}
+@fcnindex{sldb-quit}
+@c @fcnindex{sldb-reference-properties}
+@c @fcnindex{sldb-restart-at-point}
+@fcnindex{sldb-restart-frame}
+@fcnindex{sldb-return-from-frame}
+@c @fcnindex{sldb-setup}
+@c @fcnindex{sldb-show-frame-details}
+@c @fcnindex{sldb-show-frame-source}
+@fcnindex{sldb-show-source}
+@fcnindex{sldb-step}
+@c @fcnindex{sldb-sugar-move}
+@fcnindex{sldb-toggle-details}
+@c @fcnindex{sldb-up}
+@c @fcnindex{sldb-var-number-at-point}
+@c @fcnindex{sldb-xemacs-emulate-point-entered-hook}
+@c @fcnindex{sldb-xemacs-post-command-hook}
+
+
+@c @fcnindex{inferior-slime-closing-return}
+@c @fcnindex{inferior-slime-indent-line}
+@c @fcnindex{inferior-slime-mode}
+@c @fcnindex{inferior-slime-return}
+@fcnindex{slime-abort-connection}
+@fcnindex{slime-apropos}
+@fcnindex{slime-apropos-all}
+@fcnindex{slime-apropos-package}
+@c @fcnindex{slime-arglist}
+@fcnindex{slime-autodoc-mode}
+@c @fcnindex{slime-autodoc-start-timer}
+@c @fcnindex{slime-background-activities-enabled-p}
+@c @fcnindex{slime-background-message}
+@c @fcnindex{slime-browse-classes}
+@c @fcnindex{slime-browse-xrefs}
+@fcnindex{slime-call-defun}
+@fcnindex{slime-calls-who}
+@c @fcnindex{slime-check-coding-system}
+@fcnindex{slime-close-all-sexp}
+@fcnindex{slime-close-parens-at-point}
+@fcnindex{slime-compile-and-load-file}
+@fcnindex{slime-compile-defun}
+@fcnindex{slime-compile-file}
+@fcnindex{slime-compile-region}
+@fcnindex{slime-compiler-macroexpand}
+@fcnindex{slime-compiler-macroexpand-1}
+@c @fcnindex{slime-compiler-notes-default-action-or-show-details}
+@c @fcnindex{slime-compiler-notes-default-action-or-show-details/mouse}
+@c @fcnindex{slime-compiler-notes-quit}
+@c @fcnindex{slime-compiler-notes-show-details}
+@c @fcnindex{slime-complete-form}
+@fcnindex{slime-complete-symbol}
+@fcnindex{slime-connect}
+@fcnindex{slime-connection-list-make-default}
+@c @fcnindex{slime-connection-list-mode}
+@c @fcnindex{slime-copy-presentation-at-point}
+@fcnindex{slime-describe-function}
+@fcnindex{slime-describe-symbol}
+@fcnindex{slime-disassemble-symbol}
+@fcnindex{slime-disconnect}
+@c @fcnindex{slime-documentation}
+@fcnindex{slime-edit-definition}
+@fcnindex{slime-edit-definition-other-frame}
+@fcnindex{slime-edit-definition-other-window}
+@fcnindex{slime-edit-definition-with-etags}
+@fcnindex{slime-edit-value}
+@c @fcnindex{slime-edit-value-commit}
+@c @fcnindex{slime-edit-value-mode}
+@fcnindex{slime-ensure-typeout-frame}
+@c @fcnindex{slime-eval-buffer}
+@fcnindex{slime-eval-defun}
+@fcnindex{slime-eval-last-expression}
+@fcnindex{slime-eval-last-expression-display-output}
+@c @fcnindex{slime-eval-print-last-expression}
+@fcnindex{slime-eval-region}
+@fcnindex{slime-fuzzy-abort}
+@fcnindex{slime-fuzzy-complete-symbol}
+@fcnindex{slime-fuzzy-completions-mode}
+@c @fcnindex{slime-fuzzy-next}
+@c @fcnindex{slime-fuzzy-prev}
+@c @fcnindex{slime-fuzzy-select}
+@c @fcnindex{slime-fuzzy-select/mouse}
+@fcnindex{slime-goto-connection}
+@fcnindex{slime-goto-xref}
+@c @fcnindex{slime-handle-repl-shortcut}
+@c @fcnindex{slime-highlight-notes}
+@fcnindex{slime-hyperspec-lookup}
+@c @fcnindex{slime-indent-and-complete-symbol}
+@c @fcnindex{slime-init-keymaps}
+@c @fcnindex{slime-insert-arglist}
+@c @fcnindex{slime-insert-balanced-comments}
+@fcnindex{slime-inspect}
+@fcnindex{slime-inspector-copy-down}
+@fcnindex{slime-inspector-describe}
+@fcnindex{slime-inspector-next}
+@c @fcnindex{slime-inspector-next-inspectable-object}
+@fcnindex{slime-inspector-quit}
+@c @fcnindex{slime-inspector-reinspect}
+@fcnindex{slime-interactive-eval}
+@fcnindex{slime-interrupt}
+@fcnindex{slime-list-callees}
+@fcnindex{slime-list-callers}
+@c @fcnindex{slime-list-compiler-notes}
+@fcnindex{slime-list-connections}
+@c @fcnindex{slime-list-repl-shortcuts}
+@fcnindex{slime-list-threads}
+@fcnindex{slime-load-file}
+@c @fcnindex{slime-load-system}
+@fcnindex{slime-macroexpand-1}
+@fcnindex{slime-macroexpand-1-inplace}
+@fcnindex{slime-macroexpand-all}
+@c @fcnindex{slime-make-default-connection}
+@c @fcnindex{slime-make-typeout-frame}
+@fcnindex{slime-mode}
+@c @fcnindex{slime-next-line/not-add-newlines}
+@c @fcnindex{slime-next-location}
+@fcnindex{slime-next-note}
+@fcnindex{slime-nop}
+@c @fcnindex{slime-ping}
+@fcnindex{slime-pop-find-definition-stack}
+@fcnindex{slime-pprint-eval-last-expression}
+@c @fcnindex{slime-presentation-menu}
+@c @fcnindex{slime-pretty-lambdas}
+@fcnindex{slime-previous-note}
+@fcnindex{slime-profile-package}
+@fcnindex{slime-profile-report}
+@fcnindex{slime-profile-reset}
+@fcnindex{slime-profiled-functions}
+@fcnindex{slime-quit}
+@c @fcnindex{slime-quit-connection-at-point}
+@c @fcnindex{slime-quit-lisp}
+@c @fcnindex{slime-re-evaluate-defvar}
+@c @fcnindex{slime-recompile-bytecode}
+@c @fcnindex{slime-register-lisp-implementation}
+@fcnindex{slime-reindent-defun}
+@c @fcnindex{slime-remove-balanced-comments}
+@fcnindex{slime-remove-notes}
+@c @fcnindex{slime-repl}
+@fcnindex{slime-repl-beginning-of-defun}
+@fcnindex{slime-repl-bol}
+@fcnindex{slime-repl-clear-buffer}
+@fcnindex{slime-repl-clear-output}
+@fcnindex{slime-repl-closing-return}
+@c @fcnindex{slime-repl-compile-and-load}
+@c @fcnindex{slime-repl-compile-system}
+@c @fcnindex{slime-repl-compile/force-system}
+@c @fcnindex{slime-repl-defparameter}
+@fcnindex{slime-repl-end-of-defun}
+@c @fcnindex{slime-repl-eol}
+@c @fcnindex{slime-repl-load-system}
+@c @fcnindex{slime-repl-load/force-system}
+@c @fcnindex{slime-repl-mode}
+@fcnindex{slime-repl-newline-and-indent}
+@fcnindex{slime-repl-next-input}
+@fcnindex{slime-repl-next-matching-input}
+@fcnindex{slime-repl-next-prompt}
+@c @fcnindex{slime-repl-pop-directory}
+@c @fcnindex{slime-repl-pop-packages}
+@fcnindex{slime-repl-previous-input}
+@fcnindex{slime-repl-previous-matching-input}
+@fcnindex{slime-repl-previous-prompt}
+@c @fcnindex{slime-repl-push-directory}
+@c @fcnindex{slime-repl-push-package}
+@c @fcnindex{slime-repl-read-break}
+@c @fcnindex{slime-repl-read-mode}
+@fcnindex{slime-repl-return}
+@fcnindex{slime-repl-set-package}
+@c @fcnindex{slime-repl-shortcut-help}
+@c @fcnindex{slime-reset}
+@c @fcnindex{slime-restart-connection-at-point}
+@c @fcnindex{slime-restart-inferior-lisp}
+@c @fcnindex{slime-restart-inferior-lisp-aux}
+@fcnindex{slime-scratch}
+@c @fcnindex{slime-select-lisp-implementation}
+@fcnindex{slime-selector}
+@c @fcnindex{slime-send-sigint}
+@c @fcnindex{slime-set-default-directory}
+@c @fcnindex{slime-set-package}
+@c @fcnindex{slime-show-xref}
+@fcnindex{slime-space}
+@c @fcnindex{slime-start-and-load}
+@fcnindex{slime-switch-to-output-buffer}
+@fcnindex{slime-sync-package-and-default-directory}
+@c @fcnindex{slime-temp-buffer-mode}
+@fcnindex{slime-temp-buffer-quit}
+@c @fcnindex{slime-thread-attach}
+@c @fcnindex{slime-thread-debug}
+@c @fcnindex{slime-thread-control-mode}
+@c @fcnindex{slime-thread-kill}
+@c @fcnindex{slime-thread-quit}
+@fcnindex{slime-toggle-profile-fdefinition}
+@fcnindex{slime-toggle-trace-fdefinition}
+@fcnindex{slime-undefine-function}
+@fcnindex{slime-unprofile-all}
+@fcnindex{slime-untrace-all}
+@fcnindex{slime-update-connection-list}
+@c @fcnindex{slime-update-indentation} ???
+@fcnindex{slime-who-binds}
+@fcnindex{slime-who-calls}
+@fcnindex{slime-who-macroexpands}
+@fcnindex{slime-who-references}
+@fcnindex{slime-who-sets}
+@fcnindex{slime-who-specializes}
+@c @fcnindex{slime-xref-mode}
+@c @fcnindex{slime-xref-quit}
+@end table
+
+@end ignore
+
+@node Key Index
+@unnumbered Key (Character) Index
+@printindex ky
+
+@node Command Index
+@unnumbered Command and Function Index
+@printindex fn
+
+@node Variable Index
+@unnumbered Variable and Concept Index
+@printindex vr
+
+@bye
+Local Variables:
+paragraph-start: "@[a-zA-Z]+\\({[^}]+}\\)?[ \n]\\|[ ]*$"
+paragraph-separate: "@[a-zA-Z]+\\({[^}]+}\\)?[ \n]\\|[ ]*$"
+End:
Added: branches/bos/thirdparty/emacs/slime/doc/texinfo-tabulate.awk
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/doc/texinfo-tabulate.awk Fri Jan 18 06:05:59 2008
@@ -0,0 +1,21 @@
+#!/usr/bin/env awk -f
+#
+# Format input lines into a multi-column texinfo table.
+# Note: does not do texinfo-escaping of the input.
+
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
+BEGIN {
+ columns = 3;
+ printf("@multitable @columnfractions");
+ for (i = 0; i < columns; i++)
+ printf(" %f", 1.0/columns);
+ print
+}
+
+{ if (NR % columns == 1) printf("\n@item %s", $0);
+ else printf(" @tab %s", $0); }
+
+END { printf("\n@end multitable\n"); }
+
Added: branches/bos/thirdparty/emacs/slime/hyperspec.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/hyperspec.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,1671 @@
+;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec
+
+;; Copyright 1997 Naggum Software
+
+;; Author: Erik Naggum <erik(a)naggum.no>
+;; Keywords: lisp
+
+;; This file is not part of GNU Emacs, but distributed under the same
+;; conditions as GNU Emacs, and is useless without GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Kent Pitman and Xanalys Inc. have made the text of American National
+;; Standard for Information Technology -- Programming Language -- Common
+;; Lisp, ANSI X3.226-1994 available on the WWW, in the form of the Common
+;; Lisp HyperSpec. This package makes it convenient to peruse this
+;; documentation from within Emacs.
+
+;;; Code:
+
+(require 'cl)
+(require 'browse-url) ;you need the Emacs 20 version
+(require 'thingatpt)
+
+(defvar common-lisp-hyperspec-root
+ "http://www.lispworks.com/reference/HyperSpec/"
+ "The root of the Common Lisp HyperSpec URL.
+If you copy the HyperSpec to your local system, set this variable to
+something like \"file:/usr/local/doc/HyperSpec/\".")
+
+;;; Added variable for CLHS symbol table. See details below.
+;;;
+;;; 20011201 Edi Weitz
+
+(defvar common-lisp-hyperspec-symbol-table nil
+ "The HyperSpec symbol table file.
+If you copy the HyperSpec to your local system, set this variable to
+the location of the symbol table which is usually \"Map_Sym.txt\"
+or \"Symbol-Table.text\".")
+
+(defvar common-lisp-hyperspec-history nil
+ "History of symbols looked up in the Common Lisp HyperSpec.")
+
+;;if only we had had packages or hash tables..., but let's fake it.
+
+(defvar common-lisp-hyperspec-symbols (make-vector 67 0))
+
+(defun common-lisp-hyperspec-strip-cl-package (name)
+ (if (string-match "^\\([^:]*\\)::?\\([^:]*\\)$" name)
+ (let ((package-name (match-string 1 name))
+ (symbol-name (match-string 2 name)))
+ (if (member (downcase package-name)
+ '("cl" "common-lisp"))
+ symbol-name
+ name))
+ name))
+
+(defun common-lisp-hyperspec (symbol-name)
+ "View the documentation on SYMBOL-NAME from the Common Lisp HyperSpec.
+If SYMBOL-NAME has more than one definition, all of them are displayed with
+your favorite browser in sequence. The browser should have a \"back\"
+function to view the separate definitions.
+
+The Common Lisp HyperSpec is the full ANSI Standard Common Lisp, provided
+by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is
+visited to retrieve the information. Xanalys Inc. allows you to transfer
+the entire Common Lisp HyperSpec to your own site under certain conditions.
+Visit http://www.lispworks.com/reference/HyperSpec/ for more information.
+If you copy the HyperSpec to another location, customize the variable
+`common-lisp-hyperspec-root' to point to that location."
+ (interactive (list (let* ((symbol-at-point (thing-at-point 'symbol))
+ (stripped-symbol
+ (and symbol-at-point
+ (substring-no-properties
+ (downcase
+ (common-lisp-hyperspec-strip-cl-package
+ symbol-at-point))))))
+ (if (and stripped-symbol
+ (intern-soft stripped-symbol
+ common-lisp-hyperspec-symbols))
+ stripped-symbol
+ (completing-read
+ "Look up symbol in Common Lisp HyperSpec: "
+ common-lisp-hyperspec-symbols #'boundp
+ t stripped-symbol
+ 'common-lisp-hyperspec-history)))))
+ (maplist (lambda (entry)
+ (browse-url (concat common-lisp-hyperspec-root "Body/" (car entry)))
+ (if (cdr entry)
+ (sleep-for 1.5)))
+ (let ((symbol (intern-soft
+ (common-lisp-hyperspec-strip-cl-package
+ (downcase symbol-name))
+ common-lisp-hyperspec-symbols)))
+ (if (and symbol (boundp symbol))
+ (symbol-value symbol)
+ (error "The symbol `%s' is not defined in Common Lisp"
+ symbol-name)))))
+
+;;; Added the following just to provide a common entry point according
+;;; to the various 'hyperspec' implementations.
+;;;
+;;; 19990820 Marco Antoniotti
+
+(eval-when (load eval)
+ (defalias 'hyperspec-lookup 'common-lisp-hyperspec))
+
+
+;;; Added dynamic lookup of symbol in CLHS symbol table
+;;;
+;;; 20011202 Edi Weitz
+
+;;; Replaced symbol table for v 4.0 with the one for v 6.0
+;;; (which is now online at Xanalys' site)
+;;;
+;;; 20020213 Edi Weitz
+
+(if common-lisp-hyperspec-symbol-table
+ (let ((index-buffer (find-file-noselect common-lisp-hyperspec-symbol-table)))
+ (labels ((get-one-line ()
+ (prog1
+ (delete* ?\n (thing-at-point 'line))
+ (forward-line))))
+ (save-excursion
+ (set-buffer index-buffer)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (let* ((symbol (intern (downcase (get-one-line))
+ common-lisp-hyperspec-symbols))
+ (relative-url (get-one-line)))
+ (set symbol (list (subseq relative-url
+ (1+ (position ?\/ relative-url :from-end t))))))))))
+ (mapcar (lambda (entry)
+ (let ((symbol (intern (car entry) common-lisp-hyperspec-symbols)))
+ (if (boundp symbol)
+ (push (cadr entry) (symbol-value symbol))
+ (set symbol (cdr entry)))))
+ '(("&allow-other-keys" "03_da.htm")
+ ("&aux" "03_da.htm")
+ ("&body" "03_dd.htm")
+ ("&environment" "03_dd.htm")
+ ("&key" "03_da.htm")
+ ("&optional" "03_da.htm")
+ ("&rest" "03_da.htm")
+ ("&whole" "03_dd.htm")
+ ("*" "a_st.htm")
+ ("**" "v__stst_.htm")
+ ("***" "v__stst_.htm")
+ ("*break-on-signals*" "v_break_.htm")
+ ("*compile-file-pathname*" "v_cmp_fi.htm")
+ ("*compile-file-truename*" "v_cmp_fi.htm")
+ ("*compile-print*" "v_cmp_pr.htm")
+ ("*compile-verbose*" "v_cmp_pr.htm")
+ ("*debug-io*" "v_debug_.htm")
+ ("*debugger-hook*" "v_debugg.htm")
+ ("*default-pathname-defaults*" "v_defaul.htm")
+ ("*error-output*" "v_debug_.htm")
+ ("*features*" "v_featur.htm")
+ ("*gensym-counter*" "v_gensym.htm")
+ ("*load-pathname*" "v_ld_pns.htm")
+ ("*load-print*" "v_ld_prs.htm")
+ ("*load-truename*" "v_ld_pns.htm")
+ ("*load-verbose*" "v_ld_prs.htm")
+ ("*macroexpand-hook*" "v_mexp_h.htm")
+ ("*modules*" "v_module.htm")
+ ("*package*" "v_pkg.htm")
+ ("*print-array*" "v_pr_ar.htm")
+ ("*print-base*" "v_pr_bas.htm")
+ ("*print-case*" "v_pr_cas.htm")
+ ("*print-circle*" "v_pr_cir.htm")
+ ("*print-escape*" "v_pr_esc.htm")
+ ("*print-gensym*" "v_pr_gen.htm")
+ ("*print-length*" "v_pr_lev.htm")
+ ("*print-level*" "v_pr_lev.htm")
+ ("*print-lines*" "v_pr_lin.htm")
+ ("*print-miser-width*" "v_pr_mis.htm")
+ ("*print-pprint-dispatch*" "v_pr_ppr.htm")
+ ("*print-pretty*" "v_pr_pre.htm")
+ ("*print-radix*" "v_pr_bas.htm")
+ ("*print-readably*" "v_pr_rda.htm")
+ ("*print-right-margin*" "v_pr_rig.htm")
+ ("*query-io*" "v_debug_.htm")
+ ("*random-state*" "v_rnd_st.htm")
+ ("*read-base*" "v_rd_bas.htm")
+ ("*read-default-float-format*" "v_rd_def.htm")
+ ("*read-eval*" "v_rd_eva.htm")
+ ("*read-suppress*" "v_rd_sup.htm")
+ ("*readtable*" "v_rdtabl.htm")
+ ("*standard-input*" "v_debug_.htm")
+ ("*standard-output*" "v_debug_.htm")
+ ("*terminal-io*" "v_termin.htm")
+ ("*trace-output*" "v_debug_.htm")
+ ("+" "a_pl.htm")
+ ("++" "v_pl_plp.htm")
+ ("+++" "v_pl_plp.htm")
+ ("-" "a__.htm")
+ ("/" "a_sl.htm")
+ ("//" "v_sl_sls.htm")
+ ("///" "v_sl_sls.htm")
+ ("/=" "f_eq_sle.htm")
+ ("1+" "f_1pl_1_.htm")
+ ("1-" "f_1pl_1_.htm")
+ ("<" "f_eq_sle.htm")
+ ("<=" "f_eq_sle.htm")
+ ("=" "f_eq_sle.htm")
+ (">" "f_eq_sle.htm")
+ (">=" "f_eq_sle.htm")
+ ("abort" "a_abort.htm")
+ ("abs" "f_abs.htm")
+ ("acons" "f_acons.htm")
+ ("acos" "f_asin_.htm")
+ ("acosh" "f_sinh_.htm")
+ ("add-method" "f_add_me.htm")
+ ("adjoin" "f_adjoin.htm")
+ ("adjust-array" "f_adjust.htm")
+ ("adjustable-array-p" "f_adju_1.htm")
+ ("allocate-instance" "f_alloca.htm")
+ ("alpha-char-p" "f_alpha_.htm")
+ ("alphanumericp" "f_alphan.htm")
+ ("and" "a_and.htm")
+ ("append" "f_append.htm")
+ ("apply" "f_apply.htm")
+ ("apropos" "f_apropo.htm")
+ ("apropos-list" "f_apropo.htm")
+ ("aref" "f_aref.htm")
+ ("arithmetic-error" "e_arithm.htm")
+ ("arithmetic-error-operands" "f_arithm.htm")
+ ("arithmetic-error-operation" "f_arithm.htm")
+ ("array" "t_array.htm")
+ ("array-dimension" "f_ar_dim.htm")
+ ("array-dimension-limit" "v_ar_dim.htm")
+ ("array-dimensions" "f_ar_d_1.htm")
+ ("array-displacement" "f_ar_dis.htm")
+ ("array-element-type" "f_ar_ele.htm")
+ ("array-has-fill-pointer-p" "f_ar_has.htm")
+ ("array-in-bounds-p" "f_ar_in_.htm")
+ ("array-rank" "f_ar_ran.htm")
+ ("array-rank-limit" "v_ar_ran.htm")
+ ("array-row-major-index" "f_ar_row.htm")
+ ("array-total-size" "f_ar_tot.htm")
+ ("array-total-size-limit" "v_ar_tot.htm")
+ ("arrayp" "f_arrayp.htm")
+ ("ash" "f_ash.htm")
+ ("asin" "f_asin_.htm")
+ ("asinh" "f_sinh_.htm")
+ ("assert" "m_assert.htm")
+ ("assoc" "f_assocc.htm")
+ ("assoc-if" "f_assocc.htm")
+ ("assoc-if-not" "f_assocc.htm")
+ ("atan" "f_asin_.htm")
+ ("atanh" "f_sinh_.htm")
+ ("atom" "a_atom.htm")
+ ("base-char" "t_base_c.htm")
+ ("base-string" "t_base_s.htm")
+ ("bignum" "t_bignum.htm")
+ ("bit" "a_bit.htm")
+ ("bit-and" "f_bt_and.htm")
+ ("bit-andc1" "f_bt_and.htm")
+ ("bit-andc2" "f_bt_and.htm")
+ ("bit-eqv" "f_bt_and.htm")
+ ("bit-ior" "f_bt_and.htm")
+ ("bit-nand" "f_bt_and.htm")
+ ("bit-nor" "f_bt_and.htm")
+ ("bit-not" "f_bt_and.htm")
+ ("bit-orc1" "f_bt_and.htm")
+ ("bit-orc2" "f_bt_and.htm")
+ ("bit-vector" "t_bt_vec.htm")
+ ("bit-vector-p" "f_bt_vec.htm")
+ ("bit-xor" "f_bt_and.htm")
+ ("block" "s_block.htm")
+ ("boole" "f_boole.htm")
+ ("boole-1" "v_b_1_b.htm")
+ ("boole-2" "v_b_1_b.htm")
+ ("boole-and" "v_b_1_b.htm")
+ ("boole-andc1" "v_b_1_b.htm")
+ ("boole-andc2" "v_b_1_b.htm")
+ ("boole-c1" "v_b_1_b.htm")
+ ("boole-c2" "v_b_1_b.htm")
+ ("boole-clr" "v_b_1_b.htm")
+ ("boole-eqv" "v_b_1_b.htm")
+ ("boole-ior" "v_b_1_b.htm")
+ ("boole-nand" "v_b_1_b.htm")
+ ("boole-nor" "v_b_1_b.htm")
+ ("boole-orc1" "v_b_1_b.htm")
+ ("boole-orc2" "v_b_1_b.htm")
+ ("boole-set" "v_b_1_b.htm")
+ ("boole-xor" "v_b_1_b.htm")
+ ("boolean" "t_ban.htm")
+ ("both-case-p" "f_upper_.htm")
+ ("boundp" "f_boundp.htm")
+ ("break" "f_break.htm")
+ ("broadcast-stream" "t_broadc.htm")
+ ("broadcast-stream-streams" "f_broadc.htm")
+ ("built-in-class" "t_built_.htm")
+ ("butlast" "f_butlas.htm")
+ ("byte" "f_by_by.htm")
+ ("byte-position" "f_by_by.htm")
+ ("byte-size" "f_by_by.htm")
+ ("caaaar" "f_car_c.htm")
+ ("caaadr" "f_car_c.htm")
+ ("caaar" "f_car_c.htm")
+ ("caadar" "f_car_c.htm")
+ ("caaddr" "f_car_c.htm")
+ ("caadr" "f_car_c.htm")
+ ("caar" "f_car_c.htm")
+ ("cadaar" "f_car_c.htm")
+ ("cadadr" "f_car_c.htm")
+ ("cadar" "f_car_c.htm")
+ ("caddar" "f_car_c.htm")
+ ("cadddr" "f_car_c.htm")
+ ("caddr" "f_car_c.htm")
+ ("cadr" "f_car_c.htm")
+ ("call-arguments-limit" "v_call_a.htm")
+ ("call-method" "m_call_m.htm")
+ ("call-next-method" "f_call_n.htm")
+ ("car" "f_car_c.htm")
+ ("case" "m_case_.htm")
+ ("catch" "s_catch.htm")
+ ("ccase" "m_case_.htm")
+ ("cdaaar" "f_car_c.htm")
+ ("cdaadr" "f_car_c.htm")
+ ("cdaar" "f_car_c.htm")
+ ("cdadar" "f_car_c.htm")
+ ("cdaddr" "f_car_c.htm")
+ ("cdadr" "f_car_c.htm")
+ ("cdar" "f_car_c.htm")
+ ("cddaar" "f_car_c.htm")
+ ("cddadr" "f_car_c.htm")
+ ("cddar" "f_car_c.htm")
+ ("cdddar" "f_car_c.htm")
+ ("cddddr" "f_car_c.htm")
+ ("cdddr" "f_car_c.htm")
+ ("cddr" "f_car_c.htm")
+ ("cdr" "f_car_c.htm")
+ ("ceiling" "f_floorc.htm")
+ ("cell-error" "e_cell_e.htm")
+ ("cell-error-name" "f_cell_e.htm")
+ ("cerror" "f_cerror.htm")
+ ("change-class" "f_chg_cl.htm")
+ ("char" "f_char_.htm")
+ ("char-code" "f_char_c.htm")
+ ("char-code-limit" "v_char_c.htm")
+ ("char-downcase" "f_char_u.htm")
+ ("char-equal" "f_chareq.htm")
+ ("char-greaterp" "f_chareq.htm")
+ ("char-int" "f_char_i.htm")
+ ("char-lessp" "f_chareq.htm")
+ ("char-name" "f_char_n.htm")
+ ("char-not-equal" "f_chareq.htm")
+ ("char-not-greaterp" "f_chareq.htm")
+ ("char-not-lessp" "f_chareq.htm")
+ ("char-upcase" "f_char_u.htm")
+ ("char/=" "f_chareq.htm")
+ ("char<" "f_chareq.htm")
+ ("char<=" "f_chareq.htm")
+ ("char=" "f_chareq.htm")
+ ("char>" "f_chareq.htm")
+ ("char>=" "f_chareq.htm")
+ ("character" "a_ch.htm")
+ ("characterp" "f_chp.htm")
+ ("check-type" "m_check_.htm")
+ ("cis" "f_cis.htm")
+ ("class" "t_class.htm")
+ ("class-name" "f_class_.htm")
+ ("class-of" "f_clas_1.htm")
+ ("clear-input" "f_clear_.htm")
+ ("clear-output" "f_finish.htm")
+ ("close" "f_close.htm")
+ ("clrhash" "f_clrhas.htm")
+ ("code-char" "f_code_c.htm")
+ ("coerce" "f_coerce.htm")
+ ("compilation-speed" "d_optimi.htm")
+ ("compile" "f_cmp.htm")
+ ("compile-file" "f_cmp_fi.htm")
+ ("compile-file-pathname" "f_cmp__1.htm")
+ ("compiled-function" "t_cmpd_f.htm")
+ ("compiled-function-p" "f_cmpd_f.htm")
+ ("compiler-macro" "f_docume.htm")
+ ("compiler-macro-function" "f_cmp_ma.htm")
+ ("complement" "f_comple.htm")
+ ("complex" "a_comple.htm")
+ ("complexp" "f_comp_3.htm")
+ ("compute-applicable-methods" "f_comput.htm")
+ ("compute-restarts" "f_comp_1.htm")
+ ("concatenate" "f_concat.htm")
+ ("concatenated-stream" "t_concat.htm")
+ ("concatenated-stream-streams" "f_conc_1.htm")
+ ("cond" "m_cond.htm")
+ ("condition" "e_cnd.htm")
+ ("conjugate" "f_conjug.htm")
+ ("cons" "a_cons.htm")
+ ("consp" "f_consp.htm")
+ ("constantly" "f_cons_1.htm")
+ ("constantp" "f_consta.htm")
+ ("continue" "a_contin.htm")
+ ("control-error" "e_contro.htm")
+ ("copy-alist" "f_cp_ali.htm")
+ ("copy-list" "f_cp_lis.htm")
+ ("copy-pprint-dispatch" "f_cp_ppr.htm")
+ ("copy-readtable" "f_cp_rdt.htm")
+ ("copy-seq" "f_cp_seq.htm")
+ ("copy-structure" "f_cp_stu.htm")
+ ("copy-symbol" "f_cp_sym.htm")
+ ("copy-tree" "f_cp_tre.htm")
+ ("cos" "f_sin_c.htm")
+ ("cosh" "f_sinh_.htm")
+ ("count" "f_countc.htm")
+ ("count-if" "f_countc.htm")
+ ("count-if-not" "f_countc.htm")
+ ("ctypecase" "m_tpcase.htm")
+ ("debug" "d_optimi.htm")
+ ("decf" "m_incf_.htm")
+ ("declaim" "m_declai.htm")
+ ("declaration" "d_declar.htm")
+ ("declare" "s_declar.htm")
+ ("decode-float" "f_dec_fl.htm")
+ ("decode-universal-time" "f_dec_un.htm")
+ ("defclass" "m_defcla.htm")
+ ("defconstant" "m_defcon.htm")
+ ("defgeneric" "m_defgen.htm")
+ ("define-compiler-macro" "m_define.htm")
+ ("define-condition" "m_defi_5.htm")
+ ("define-method-combination" "m_defi_4.htm")
+ ("define-modify-macro" "m_defi_2.htm")
+ ("define-setf-expander" "m_defi_3.htm")
+ ("define-symbol-macro" "m_defi_1.htm")
+ ("defmacro" "m_defmac.htm")
+ ("defmethod" "m_defmet.htm")
+ ("defpackage" "m_defpkg.htm")
+ ("defparameter" "m_defpar.htm")
+ ("defsetf" "m_defset.htm")
+ ("defstruct" "m_defstr.htm")
+ ("deftype" "m_deftp.htm")
+ ("defun" "m_defun.htm")
+ ("defvar" "m_defpar.htm")
+ ("delete" "f_rm_rm.htm")
+ ("delete-duplicates" "f_rm_dup.htm")
+ ("delete-file" "f_del_fi.htm")
+ ("delete-if" "f_rm_rm.htm")
+ ("delete-if-not" "f_rm_rm.htm")
+ ("delete-package" "f_del_pk.htm")
+ ("denominator" "f_numera.htm")
+ ("deposit-field" "f_deposi.htm")
+ ("describe" "f_descri.htm")
+ ("describe-object" "f_desc_1.htm")
+ ("destructuring-bind" "m_destru.htm")
+ ("digit-char" "f_digit_.htm")
+ ("digit-char-p" "f_digi_1.htm")
+ ("directory" "f_dir.htm")
+ ("directory-namestring" "f_namest.htm")
+ ("disassemble" "f_disass.htm")
+ ("division-by-zero" "e_divisi.htm")
+ ("do" "m_do_do.htm")
+ ("do*" "m_do_do.htm")
+ ("do-all-symbols" "m_do_sym.htm")
+ ("do-external-symbols" "m_do_sym.htm")
+ ("do-symbols" "m_do_sym.htm")
+ ("documentation" "f_docume.htm")
+ ("dolist" "m_dolist.htm")
+ ("dotimes" "m_dotime.htm")
+ ("double-float" "t_short_.htm")
+ ("double-float-epsilon" "v_short_.htm")
+ ("double-float-negative-epsilon" "v_short_.htm")
+ ("dpb" "f_dpb.htm")
+ ("dribble" "f_dribbl.htm")
+ ("dynamic-extent" "d_dynami.htm")
+ ("ecase" "m_case_.htm")
+ ("echo-stream" "t_echo_s.htm")
+ ("echo-stream-input-stream" "f_echo_s.htm")
+ ("echo-stream-output-stream" "f_echo_s.htm")
+ ("ed" "f_ed.htm")
+ ("eighth" "f_firstc.htm")
+ ("elt" "f_elt.htm")
+ ("encode-universal-time" "f_encode.htm")
+ ("end-of-file" "e_end_of.htm")
+ ("endp" "f_endp.htm")
+ ("enough-namestring" "f_namest.htm")
+ ("ensure-directories-exist" "f_ensu_1.htm")
+ ("ensure-generic-function" "f_ensure.htm")
+ ("eq" "f_eq.htm")
+ ("eql" "a_eql.htm")
+ ("equal" "f_equal.htm")
+ ("equalp" "f_equalp.htm")
+ ("error" "a_error.htm")
+ ("etypecase" "m_tpcase.htm")
+ ("eval" "f_eval.htm")
+ ("eval-when" "s_eval_w.htm")
+ ("evenp" "f_evenpc.htm")
+ ("every" "f_everyc.htm")
+ ("exp" "f_exp_e.htm")
+ ("export" "f_export.htm")
+ ("expt" "f_exp_e.htm")
+ ("extended-char" "t_extend.htm")
+ ("fboundp" "f_fbound.htm")
+ ("fceiling" "f_floorc.htm")
+ ("fdefinition" "f_fdefin.htm")
+ ("ffloor" "f_floorc.htm")
+ ("fifth" "f_firstc.htm")
+ ("file-author" "f_file_a.htm")
+ ("file-error" "e_file_e.htm")
+ ("file-error-pathname" "f_file_e.htm")
+ ("file-length" "f_file_l.htm")
+ ("file-namestring" "f_namest.htm")
+ ("file-position" "f_file_p.htm")
+ ("file-stream" "t_file_s.htm")
+ ("file-string-length" "f_file_s.htm")
+ ("file-write-date" "f_file_w.htm")
+ ("fill" "f_fill.htm")
+ ("fill-pointer" "f_fill_p.htm")
+ ("find" "f_find_.htm")
+ ("find-all-symbols" "f_find_a.htm")
+ ("find-class" "f_find_c.htm")
+ ("find-if" "f_find_.htm")
+ ("find-if-not" "f_find_.htm")
+ ("find-method" "f_find_m.htm")
+ ("find-package" "f_find_p.htm")
+ ("find-restart" "f_find_r.htm")
+ ("find-symbol" "f_find_s.htm")
+ ("finish-output" "f_finish.htm")
+ ("first" "f_firstc.htm")
+ ("fixnum" "t_fixnum.htm")
+ ("flet" "s_flet_.htm")
+ ("float" "a_float.htm")
+ ("float-digits" "f_dec_fl.htm")
+ ("float-precision" "f_dec_fl.htm")
+ ("float-radix" "f_dec_fl.htm")
+ ("float-sign" "f_dec_fl.htm")
+ ("floating-point-inexact" "e_floa_1.htm")
+ ("floating-point-invalid-operation" "e_floati.htm")
+ ("floating-point-overflow" "e_floa_2.htm")
+ ("floating-point-underflow" "e_floa_3.htm")
+ ("floatp" "f_floatp.htm")
+ ("floor" "f_floorc.htm")
+ ("fmakunbound" "f_fmakun.htm")
+ ("force-output" "f_finish.htm")
+ ("format" "f_format.htm")
+ ("formatter" "m_format.htm")
+ ("fourth" "f_firstc.htm")
+ ("fresh-line" "f_terpri.htm")
+ ("fround" "f_floorc.htm")
+ ("ftruncate" "f_floorc.htm")
+ ("ftype" "d_ftype.htm")
+ ("funcall" "f_funcal.htm")
+ ("function" "a_fn.htm")
+ ("function-keywords" "f_fn_kwd.htm")
+ ("function-lambda-expression" "f_fn_lam.htm")
+ ("functionp" "f_fnp.htm")
+ ("gcd" "f_gcd.htm")
+ ("generic-function" "t_generi.htm")
+ ("gensym" "f_gensym.htm")
+ ("gentemp" "f_gentem.htm")
+ ("get" "f_get.htm")
+ ("get-decoded-time" "f_get_un.htm")
+ ("get-dispatch-macro-character" "f_set__1.htm")
+ ("get-internal-real-time" "f_get_in.htm")
+ ("get-internal-run-time" "f_get__1.htm")
+ ("get-macro-character" "f_set_ma.htm")
+ ("get-output-stream-string" "f_get_ou.htm")
+ ("get-properties" "f_get_pr.htm")
+ ("get-setf-expansion" "f_get_se.htm")
+ ("get-universal-time" "f_get_un.htm")
+ ("getf" "f_getf.htm")
+ ("gethash" "f_gethas.htm")
+ ("go" "s_go.htm")
+ ("graphic-char-p" "f_graphi.htm")
+ ("handler-bind" "m_handle.htm")
+ ("handler-case" "m_hand_1.htm")
+ ("hash-table" "t_hash_t.htm")
+ ("hash-table-count" "f_hash_1.htm")
+ ("hash-table-p" "f_hash_t.htm")
+ ("hash-table-rehash-size" "f_hash_2.htm")
+ ("hash-table-rehash-threshold" "f_hash_3.htm")
+ ("hash-table-size" "f_hash_4.htm")
+ ("hash-table-test" "f_hash_5.htm")
+ ("host-namestring" "f_namest.htm")
+ ("identity" "f_identi.htm")
+ ("if" "s_if.htm")
+ ("ignorable" "d_ignore.htm")
+ ("ignore" "d_ignore.htm")
+ ("ignore-errors" "m_ignore.htm")
+ ("imagpart" "f_realpa.htm")
+ ("import" "f_import.htm")
+ ("in-package" "m_in_pkg.htm")
+ ("incf" "m_incf_.htm")
+ ("initialize-instance" "f_init_i.htm")
+ ("inline" "d_inline.htm")
+ ("input-stream-p" "f_in_stm.htm")
+ ("inspect" "f_inspec.htm")
+ ("integer" "t_intege.htm")
+ ("integer-decode-float" "f_dec_fl.htm")
+ ("integer-length" "f_intege.htm")
+ ("integerp" "f_inte_1.htm")
+ ("interactive-stream-p" "f_intera.htm")
+ ("intern" "f_intern.htm")
+ ("internal-time-units-per-second" "v_intern.htm")
+ ("intersection" "f_isec_.htm")
+ ("invalid-method-error" "f_invali.htm")
+ ("invoke-debugger" "f_invoke.htm")
+ ("invoke-restart" "f_invo_1.htm")
+ ("invoke-restart-interactively" "f_invo_2.htm")
+ ("isqrt" "f_sqrt_.htm")
+ ("keyword" "t_kwd.htm")
+ ("keywordp" "f_kwdp.htm")
+ ("labels" "s_flet_.htm")
+ ("lambda" "a_lambda.htm")
+ ("lambda-list-keywords" "v_lambda.htm")
+ ("lambda-parameters-limit" "v_lamb_1.htm")
+ ("last" "f_last.htm")
+ ("lcm" "f_lcm.htm")
+ ("ldb" "f_ldb.htm")
+ ("ldb-test" "f_ldb_te.htm")
+ ("ldiff" "f_ldiffc.htm")
+ ("least-negative-double-float" "v_most_1.htm")
+ ("least-negative-long-float" "v_most_1.htm")
+ ("least-negative-normalized-double-float" "v_most_1.htm")
+ ("least-negative-normalized-long-float" "v_most_1.htm")
+ ("least-negative-normalized-short-float" "v_most_1.htm")
+ ("least-negative-normalized-single-float" "v_most_1.htm")
+ ("least-negative-short-float" "v_most_1.htm")
+ ("least-negative-single-float" "v_most_1.htm")
+ ("least-positive-double-float" "v_most_1.htm")
+ ("least-positive-long-float" "v_most_1.htm")
+ ("least-positive-normalized-double-float" "v_most_1.htm")
+ ("least-positive-normalized-long-float" "v_most_1.htm")
+ ("least-positive-normalized-short-float" "v_most_1.htm")
+ ("least-positive-normalized-single-float" "v_most_1.htm")
+ ("least-positive-short-float" "v_most_1.htm")
+ ("least-positive-single-float" "v_most_1.htm")
+ ("length" "f_length.htm")
+ ("let" "s_let_l.htm")
+ ("let*" "s_let_l.htm")
+ ("lisp-implementation-type" "f_lisp_i.htm")
+ ("lisp-implementation-version" "f_lisp_i.htm")
+ ("list" "a_list.htm")
+ ("list*" "f_list_.htm")
+ ("list-all-packages" "f_list_a.htm")
+ ("list-length" "f_list_l.htm")
+ ("listen" "f_listen.htm")
+ ("listp" "f_listp.htm")
+ ("load" "f_load.htm")
+ ("load-logical-pathname-translations" "f_ld_log.htm")
+ ("load-time-value" "s_ld_tim.htm")
+ ("locally" "s_locall.htm")
+ ("log" "f_log.htm")
+ ("logand" "f_logand.htm")
+ ("logandc1" "f_logand.htm")
+ ("logandc2" "f_logand.htm")
+ ("logbitp" "f_logbtp.htm")
+ ("logcount" "f_logcou.htm")
+ ("logeqv" "f_logand.htm")
+ ("logical-pathname" "a_logica.htm")
+ ("logical-pathname-translations" "f_logica.htm")
+ ("logior" "f_logand.htm")
+ ("lognand" "f_logand.htm")
+ ("lognor" "f_logand.htm")
+ ("lognot" "f_logand.htm")
+ ("logorc1" "f_logand.htm")
+ ("logorc2" "f_logand.htm")
+ ("logtest" "f_logtes.htm")
+ ("logxor" "f_logand.htm")
+ ("long-float" "t_short_.htm")
+ ("long-float-epsilon" "v_short_.htm")
+ ("long-float-negative-epsilon" "v_short_.htm")
+ ("long-site-name" "f_short_.htm")
+ ("loop" "m_loop.htm")
+ ("loop-finish" "m_loop_f.htm")
+ ("lower-case-p" "f_upper_.htm")
+ ("machine-instance" "f_mach_i.htm")
+ ("machine-type" "f_mach_t.htm")
+ ("machine-version" "f_mach_v.htm")
+ ("macro-function" "f_macro_.htm")
+ ("macroexpand" "f_mexp_.htm")
+ ("macroexpand-1" "f_mexp_.htm")
+ ("macrolet" "s_flet_.htm")
+ ("make-array" "f_mk_ar.htm")
+ ("make-broadcast-stream" "f_mk_bro.htm")
+ ("make-concatenated-stream" "f_mk_con.htm")
+ ("make-condition" "f_mk_cnd.htm")
+ ("make-dispatch-macro-character" "f_mk_dis.htm")
+ ("make-echo-stream" "f_mk_ech.htm")
+ ("make-hash-table" "f_mk_has.htm")
+ ("make-instance" "f_mk_ins.htm")
+ ("make-instances-obsolete" "f_mk_i_1.htm")
+ ("make-list" "f_mk_lis.htm")
+ ("make-load-form" "f_mk_ld_.htm")
+ ("make-load-form-saving-slots" "f_mk_l_1.htm")
+ ("make-method" "m_call_m.htm")
+ ("make-package" "f_mk_pkg.htm")
+ ("make-pathname" "f_mk_pn.htm")
+ ("make-random-state" "f_mk_rnd.htm")
+ ("make-sequence" "f_mk_seq.htm")
+ ("make-string" "f_mk_stg.htm")
+ ("make-string-input-stream" "f_mk_s_1.htm")
+ ("make-string-output-stream" "f_mk_s_2.htm")
+ ("make-symbol" "f_mk_sym.htm")
+ ("make-synonym-stream" "f_mk_syn.htm")
+ ("make-two-way-stream" "f_mk_two.htm")
+ ("makunbound" "f_makunb.htm")
+ ("map" "f_map.htm")
+ ("map-into" "f_map_in.htm")
+ ("mapc" "f_mapc_.htm")
+ ("mapcan" "f_mapc_.htm")
+ ("mapcar" "f_mapc_.htm")
+ ("mapcon" "f_mapc_.htm")
+ ("maphash" "f_maphas.htm")
+ ("mapl" "f_mapc_.htm")
+ ("maplist" "f_mapc_.htm")
+ ("mask-field" "f_mask_f.htm")
+ ("max" "f_max_m.htm")
+ ("member" "a_member.htm")
+ ("member-if" "f_mem_m.htm")
+ ("member-if-not" "f_mem_m.htm")
+ ("merge" "f_merge.htm")
+ ("merge-pathnames" "f_merge_.htm")
+ ("method" "t_method.htm")
+ ("method-combination" "a_method.htm")
+ ("method-combination-error" "f_meth_1.htm")
+ ("method-qualifiers" "f_method.htm")
+ ("min" "f_max_m.htm")
+ ("minusp" "f_minusp.htm")
+ ("mismatch" "f_mismat.htm")
+ ("mod" "a_mod.htm")
+ ("most-negative-double-float" "v_most_1.htm")
+ ("most-negative-fixnum" "v_most_p.htm")
+ ("most-negative-long-float" "v_most_1.htm")
+ ("most-negative-short-float" "v_most_1.htm")
+ ("most-negative-single-float" "v_most_1.htm")
+ ("most-positive-double-float" "v_most_1.htm")
+ ("most-positive-fixnum" "v_most_p.htm")
+ ("most-positive-long-float" "v_most_1.htm")
+ ("most-positive-short-float" "v_most_1.htm")
+ ("most-positive-single-float" "v_most_1.htm")
+ ("muffle-warning" "a_muffle.htm")
+ ("multiple-value-bind" "m_multip.htm")
+ ("multiple-value-call" "s_multip.htm")
+ ("multiple-value-list" "m_mult_1.htm")
+ ("multiple-value-prog1" "s_mult_1.htm")
+ ("multiple-value-setq" "m_mult_2.htm")
+ ("multiple-values-limit" "v_multip.htm")
+ ("name-char" "f_name_c.htm")
+ ("namestring" "f_namest.htm")
+ ("nbutlast" "f_butlas.htm")
+ ("nconc" "f_nconc.htm")
+ ("next-method-p" "f_next_m.htm")
+ ("nil" "a_nil.htm")
+ ("nintersection" "f_isec_.htm")
+ ("ninth" "f_firstc.htm")
+ ("no-applicable-method" "f_no_app.htm")
+ ("no-next-method" "f_no_nex.htm")
+ ("not" "a_not.htm")
+ ("notany" "f_everyc.htm")
+ ("notevery" "f_everyc.htm")
+ ("notinline" "d_inline.htm")
+ ("nreconc" "f_revapp.htm")
+ ("nreverse" "f_revers.htm")
+ ("nset-difference" "f_set_di.htm")
+ ("nset-exclusive-or" "f_set_ex.htm")
+ ("nstring-capitalize" "f_stg_up.htm")
+ ("nstring-downcase" "f_stg_up.htm")
+ ("nstring-upcase" "f_stg_up.htm")
+ ("nsublis" "f_sublis.htm")
+ ("nsubst" "f_substc.htm")
+ ("nsubst-if" "f_substc.htm")
+ ("nsubst-if-not" "f_substc.htm")
+ ("nsubstitute" "f_sbs_s.htm")
+ ("nsubstitute-if" "f_sbs_s.htm")
+ ("nsubstitute-if-not" "f_sbs_s.htm")
+ ("nth" "f_nth.htm")
+ ("nth-value" "m_nth_va.htm")
+ ("nthcdr" "f_nthcdr.htm")
+ ("null" "a_null.htm")
+ ("number" "t_number.htm")
+ ("numberp" "f_nump.htm")
+ ("numerator" "f_numera.htm")
+ ("nunion" "f_unionc.htm")
+ ("oddp" "f_evenpc.htm")
+ ("open" "f_open.htm")
+ ("open-stream-p" "f_open_s.htm")
+ ("optimize" "d_optimi.htm")
+ ("or" "a_or.htm")
+ ("otherwise" "m_case_.htm")
+ ("output-stream-p" "f_in_stm.htm")
+ ("package" "t_pkg.htm")
+ ("package-error" "e_pkg_er.htm")
+ ("package-error-package" "f_pkg_er.htm")
+ ("package-name" "f_pkg_na.htm")
+ ("package-nicknames" "f_pkg_ni.htm")
+ ("package-shadowing-symbols" "f_pkg_sh.htm")
+ ("package-use-list" "f_pkg_us.htm")
+ ("package-used-by-list" "f_pkg__1.htm")
+ ("packagep" "f_pkgp.htm")
+ ("pairlis" "f_pairli.htm")
+ ("parse-error" "e_parse_.htm")
+ ("parse-integer" "f_parse_.htm")
+ ("parse-namestring" "f_pars_1.htm")
+ ("pathname" "a_pn.htm")
+ ("pathname-device" "f_pn_hos.htm")
+ ("pathname-directory" "f_pn_hos.htm")
+ ("pathname-host" "f_pn_hos.htm")
+ ("pathname-match-p" "f_pn_mat.htm")
+ ("pathname-name" "f_pn_hos.htm")
+ ("pathname-type" "f_pn_hos.htm")
+ ("pathname-version" "f_pn_hos.htm")
+ ("pathnamep" "f_pnp.htm")
+ ("peek-char" "f_peek_c.htm")
+ ("phase" "f_phase.htm")
+ ("pi" "v_pi.htm")
+ ("plusp" "f_minusp.htm")
+ ("pop" "m_pop.htm")
+ ("position" "f_pos_p.htm")
+ ("position-if" "f_pos_p.htm")
+ ("position-if-not" "f_pos_p.htm")
+ ("pprint" "f_wr_pr.htm")
+ ("pprint-dispatch" "f_ppr_di.htm")
+ ("pprint-exit-if-list-exhausted" "m_ppr_ex.htm")
+ ("pprint-fill" "f_ppr_fi.htm")
+ ("pprint-indent" "f_ppr_in.htm")
+ ("pprint-linear" "f_ppr_fi.htm")
+ ("pprint-logical-block" "m_ppr_lo.htm")
+ ("pprint-newline" "f_ppr_nl.htm")
+ ("pprint-pop" "m_ppr_po.htm")
+ ("pprint-tab" "f_ppr_ta.htm")
+ ("pprint-tabular" "f_ppr_fi.htm")
+ ("prin1" "f_wr_pr.htm")
+ ("prin1-to-string" "f_wr_to_.htm")
+ ("princ" "f_wr_pr.htm")
+ ("princ-to-string" "f_wr_to_.htm")
+ ("print" "f_wr_pr.htm")
+ ("print-not-readable" "e_pr_not.htm")
+ ("print-not-readable-object" "f_pr_not.htm")
+ ("print-object" "f_pr_obj.htm")
+ ("print-unreadable-object" "m_pr_unr.htm")
+ ("probe-file" "f_probe_.htm")
+ ("proclaim" "f_procla.htm")
+ ("prog" "m_prog_.htm")
+ ("prog*" "m_prog_.htm")
+ ("prog1" "m_prog1c.htm")
+ ("prog2" "m_prog1c.htm")
+ ("progn" "s_progn.htm")
+ ("program-error" "e_progra.htm")
+ ("progv" "s_progv.htm")
+ ("provide" "f_provid.htm")
+ ("psetf" "m_setf_.htm")
+ ("psetq" "m_psetq.htm")
+ ("push" "m_push.htm")
+ ("pushnew" "m_pshnew.htm")
+ ("quote" "s_quote.htm")
+ ("random" "f_random.htm")
+ ("random-state" "t_rnd_st.htm")
+ ("random-state-p" "f_rnd_st.htm")
+ ("rassoc" "f_rassoc.htm")
+ ("rassoc-if" "f_rassoc.htm")
+ ("rassoc-if-not" "f_rassoc.htm")
+ ("ratio" "t_ratio.htm")
+ ("rational" "a_ration.htm")
+ ("rationalize" "f_ration.htm")
+ ("rationalp" "f_rati_1.htm")
+ ("read" "f_rd_rd.htm")
+ ("read-byte" "f_rd_by.htm")
+ ("read-char" "f_rd_cha.htm")
+ ("read-char-no-hang" "f_rd_c_1.htm")
+ ("read-delimited-list" "f_rd_del.htm")
+ ("read-from-string" "f_rd_fro.htm")
+ ("read-line" "f_rd_lin.htm")
+ ("read-preserving-whitespace" "f_rd_rd.htm")
+ ("read-sequence" "f_rd_seq.htm")
+ ("reader-error" "e_rder_e.htm")
+ ("readtable" "t_rdtabl.htm")
+ ("readtable-case" "f_rdtabl.htm")
+ ("readtablep" "f_rdta_1.htm")
+ ("real" "t_real.htm")
+ ("realp" "f_realp.htm")
+ ("realpart" "f_realpa.htm")
+ ("reduce" "f_reduce.htm")
+ ("reinitialize-instance" "f_reinit.htm")
+ ("rem" "f_mod_r.htm")
+ ("remf" "m_remf.htm")
+ ("remhash" "f_remhas.htm")
+ ("remove" "f_rm_rm.htm")
+ ("remove-duplicates" "f_rm_dup.htm")
+ ("remove-if" "f_rm_rm.htm")
+ ("remove-if-not" "f_rm_rm.htm")
+ ("remove-method" "f_rm_met.htm")
+ ("remprop" "f_rempro.htm")
+ ("rename-file" "f_rn_fil.htm")
+ ("rename-package" "f_rn_pkg.htm")
+ ("replace" "f_replac.htm")
+ ("require" "f_provid.htm")
+ ("rest" "f_rest.htm")
+ ("restart" "t_rst.htm")
+ ("restart-bind" "m_rst_bi.htm")
+ ("restart-case" "m_rst_ca.htm")
+ ("restart-name" "f_rst_na.htm")
+ ("return" "m_return.htm")
+ ("return-from" "s_ret_fr.htm")
+ ("revappend" "f_revapp.htm")
+ ("reverse" "f_revers.htm")
+ ("room" "f_room.htm")
+ ("rotatef" "m_rotate.htm")
+ ("round" "f_floorc.htm")
+ ("row-major-aref" "f_row_ma.htm")
+ ("rplaca" "f_rplaca.htm")
+ ("rplacd" "f_rplaca.htm")
+ ("safety" "d_optimi.htm")
+ ("satisfies" "t_satisf.htm")
+ ("sbit" "f_bt_sb.htm")
+ ("scale-float" "f_dec_fl.htm")
+ ("schar" "f_char_.htm")
+ ("search" "f_search.htm")
+ ("second" "f_firstc.htm")
+ ("sequence" "t_seq.htm")
+ ("serious-condition" "e_seriou.htm")
+ ("set" "f_set.htm")
+ ("set-difference" "f_set_di.htm")
+ ("set-dispatch-macro-character" "f_set__1.htm")
+ ("set-exclusive-or" "f_set_ex.htm")
+ ("set-macro-character" "f_set_ma.htm")
+ ("set-pprint-dispatch" "f_set_pp.htm")
+ ("set-syntax-from-char" "f_set_sy.htm")
+ ("setf" "a_setf.htm")
+ ("setq" "s_setq.htm")
+ ("seventh" "f_firstc.htm")
+ ("shadow" "f_shadow.htm")
+ ("shadowing-import" "f_shdw_i.htm")
+ ("shared-initialize" "f_shared.htm")
+ ("shiftf" "m_shiftf.htm")
+ ("short-float" "t_short_.htm")
+ ("short-float-epsilon" "v_short_.htm")
+ ("short-float-negative-epsilon" "v_short_.htm")
+ ("short-site-name" "f_short_.htm")
+ ("signal" "f_signal.htm")
+ ("signed-byte" "t_sgn_by.htm")
+ ("signum" "f_signum.htm")
+ ("simple-array" "t_smp_ar.htm")
+ ("simple-base-string" "t_smp_ba.htm")
+ ("simple-bit-vector" "t_smp_bt.htm")
+ ("simple-bit-vector-p" "f_smp_bt.htm")
+ ("simple-condition" "e_smp_cn.htm")
+ ("simple-condition-format-arguments" "f_smp_cn.htm")
+ ("simple-condition-format-control" "f_smp_cn.htm")
+ ("simple-error" "e_smp_er.htm")
+ ("simple-string" "t_smp_st.htm")
+ ("simple-string-p" "f_smp_st.htm")
+ ("simple-type-error" "e_smp_tp.htm")
+ ("simple-vector" "t_smp_ve.htm")
+ ("simple-vector-p" "f_smp_ve.htm")
+ ("simple-warning" "e_smp_wa.htm")
+ ("sin" "f_sin_c.htm")
+ ("single-float" "t_short_.htm")
+ ("single-float-epsilon" "v_short_.htm")
+ ("single-float-negative-epsilon" "v_short_.htm")
+ ("sinh" "f_sinh_.htm")
+ ("sixth" "f_firstc.htm")
+ ("sleep" "f_sleep.htm")
+ ("slot-boundp" "f_slt_bo.htm")
+ ("slot-exists-p" "f_slt_ex.htm")
+ ("slot-makunbound" "f_slt_ma.htm")
+ ("slot-missing" "f_slt_mi.htm")
+ ("slot-unbound" "f_slt_un.htm")
+ ("slot-value" "f_slt_va.htm")
+ ("software-type" "f_sw_tpc.htm")
+ ("software-version" "f_sw_tpc.htm")
+ ("some" "f_everyc.htm")
+ ("sort" "f_sort_.htm")
+ ("space" "d_optimi.htm")
+ ("special" "d_specia.htm")
+ ("special-operator-p" "f_specia.htm")
+ ("speed" "d_optimi.htm")
+ ("sqrt" "f_sqrt_.htm")
+ ("stable-sort" "f_sort_.htm")
+ ("standard" "07_ffb.htm")
+ ("standard-char" "t_std_ch.htm")
+ ("standard-char-p" "f_std_ch.htm")
+ ("standard-class" "t_std_cl.htm")
+ ("standard-generic-function" "t_std_ge.htm")
+ ("standard-method" "t_std_me.htm")
+ ("standard-object" "t_std_ob.htm")
+ ("step" "m_step.htm")
+ ("storage-condition" "e_storag.htm")
+ ("store-value" "a_store_.htm")
+ ("stream" "t_stream.htm")
+ ("stream-element-type" "f_stm_el.htm")
+ ("stream-error" "e_stm_er.htm")
+ ("stream-error-stream" "f_stm_er.htm")
+ ("stream-external-format" "f_stm_ex.htm")
+ ("streamp" "f_stmp.htm")
+ ("string" "a_string.htm")
+ ("string-capitalize" "f_stg_up.htm")
+ ("string-downcase" "f_stg_up.htm")
+ ("string-equal" "f_stgeq_.htm")
+ ("string-greaterp" "f_stgeq_.htm")
+ ("string-left-trim" "f_stg_tr.htm")
+ ("string-lessp" "f_stgeq_.htm")
+ ("string-not-equal" "f_stgeq_.htm")
+ ("string-not-greaterp" "f_stgeq_.htm")
+ ("string-not-lessp" "f_stgeq_.htm")
+ ("string-right-trim" "f_stg_tr.htm")
+ ("string-stream" "t_stg_st.htm")
+ ("string-trim" "f_stg_tr.htm")
+ ("string-upcase" "f_stg_up.htm")
+ ("string/=" "f_stgeq_.htm")
+ ("string<" "f_stgeq_.htm")
+ ("string<=" "f_stgeq_.htm")
+ ("string=" "f_stgeq_.htm")
+ ("string>" "f_stgeq_.htm")
+ ("string>=" "f_stgeq_.htm")
+ ("stringp" "f_stgp.htm")
+ ("structure" "f_docume.htm")
+ ("structure-class" "t_stu_cl.htm")
+ ("structure-object" "t_stu_ob.htm")
+ ("style-warning" "e_style_.htm")
+ ("sublis" "f_sublis.htm")
+ ("subseq" "f_subseq.htm")
+ ("subsetp" "f_subset.htm")
+ ("subst" "f_substc.htm")
+ ("subst-if" "f_substc.htm")
+ ("subst-if-not" "f_substc.htm")
+ ("substitute" "f_sbs_s.htm")
+ ("substitute-if" "f_sbs_s.htm")
+ ("substitute-if-not" "f_sbs_s.htm")
+ ("subtypep" "f_subtpp.htm")
+ ("svref" "f_svref.htm")
+ ("sxhash" "f_sxhash.htm")
+ ("symbol" "t_symbol.htm")
+ ("symbol-function" "f_symb_1.htm")
+ ("symbol-macrolet" "s_symbol.htm")
+ ("symbol-name" "f_symb_2.htm")
+ ("symbol-package" "f_symb_3.htm")
+ ("symbol-plist" "f_symb_4.htm")
+ ("symbol-value" "f_symb_5.htm")
+ ("symbolp" "f_symbol.htm")
+ ("synonym-stream" "t_syn_st.htm")
+ ("synonym-stream-symbol" "f_syn_st.htm")
+ ("t" "a_t.htm")
+ ("tagbody" "s_tagbod.htm")
+ ("tailp" "f_ldiffc.htm")
+ ("tan" "f_sin_c.htm")
+ ("tanh" "f_sinh_.htm")
+ ("tenth" "f_firstc.htm")
+ ("terpri" "f_terpri.htm")
+ ("the" "s_the.htm")
+ ("third" "f_firstc.htm")
+ ("throw" "s_throw.htm")
+ ("time" "m_time.htm")
+ ("trace" "m_tracec.htm")
+ ("translate-logical-pathname" "f_tr_log.htm")
+ ("translate-pathname" "f_tr_pn.htm")
+ ("tree-equal" "f_tree_e.htm")
+ ("truename" "f_tn.htm")
+ ("truncate" "f_floorc.htm")
+ ("two-way-stream" "t_two_wa.htm")
+ ("two-way-stream-input-stream" "f_two_wa.htm")
+ ("two-way-stream-output-stream" "f_two_wa.htm")
+ ("type" "a_type.htm")
+ ("type-error" "e_tp_err.htm")
+ ("type-error-datum" "f_tp_err.htm")
+ ("type-error-expected-type" "f_tp_err.htm")
+ ("type-of" "f_tp_of.htm")
+ ("typecase" "m_tpcase.htm")
+ ("typep" "f_typep.htm")
+ ("unbound-slot" "e_unboun.htm")
+ ("unbound-slot-instance" "f_unboun.htm")
+ ("unbound-variable" "e_unbo_1.htm")
+ ("undefined-function" "e_undefi.htm")
+ ("unexport" "f_unexpo.htm")
+ ("unintern" "f_uninte.htm")
+ ("union" "f_unionc.htm")
+ ("unless" "m_when_.htm")
+ ("unread-char" "f_unrd_c.htm")
+ ("unsigned-byte" "t_unsgn_.htm")
+ ("untrace" "m_tracec.htm")
+ ("unuse-package" "f_unuse_.htm")
+ ("unwind-protect" "s_unwind.htm")
+ ("update-instance-for-different-class" "f_update.htm")
+ ("update-instance-for-redefined-class" "f_upda_1.htm")
+ ("upgraded-array-element-type" "f_upgr_1.htm")
+ ("upgraded-complex-part-type" "f_upgrad.htm")
+ ("upper-case-p" "f_upper_.htm")
+ ("use-package" "f_use_pk.htm")
+ ("use-value" "a_use_va.htm")
+ ("user-homedir-pathname" "f_user_h.htm")
+ ("values" "a_values.htm")
+ ("values-list" "f_vals_l.htm")
+ ("variable" "f_docume.htm")
+ ("vector" "a_vector.htm")
+ ("vector-pop" "f_vec_po.htm")
+ ("vector-push" "f_vec_ps.htm")
+ ("vector-push-extend" "f_vec_ps.htm")
+ ("vectorp" "f_vecp.htm")
+ ("warn" "f_warn.htm")
+ ("warning" "e_warnin.htm")
+ ("when" "m_when_.htm")
+ ("wild-pathname-p" "f_wild_p.htm")
+ ("with-accessors" "m_w_acce.htm")
+ ("with-compilation-unit" "m_w_comp.htm")
+ ("with-condition-restarts" "m_w_cnd_.htm")
+ ("with-hash-table-iterator" "m_w_hash.htm")
+ ("with-input-from-string" "m_w_in_f.htm")
+ ("with-open-file" "m_w_open.htm")
+ ("with-open-stream" "m_w_op_1.htm")
+ ("with-output-to-string" "m_w_out_.htm")
+ ("with-package-iterator" "m_w_pkg_.htm")
+ ("with-simple-restart" "m_w_smp_.htm")
+ ("with-slots" "m_w_slts.htm")
+ ("with-standard-io-syntax" "m_w_std_.htm")
+ ("write" "f_wr_pr.htm")
+ ("write-byte" "f_wr_by.htm")
+ ("write-char" "f_wr_cha.htm")
+ ("write-line" "f_wr_stg.htm")
+ ("write-sequence" "f_wr_seq.htm")
+ ("write-string" "f_wr_stg.htm")
+ ("write-to-string" "f_wr_to_.htm")
+ ("y-or-n-p" "f_y_or_n.htm")
+ ("yes-or-no-p" "f_y_or_n.htm")
+ ("zerop" "f_zerop.htm"))))
+
+;;; FORMAT character lookup by Frode Vatvedt Fjeld <frodef(a)acm.org> 20030902
+;;;
+;;; adjusted for ILISP by Nikodemus Siivola 20030903
+
+(defvar common-lisp-hyperspec-format-history nil
+ "History of format characters looked up in the Common Lisp HyperSpec.")
+
+(defvar common-lisp-hyperspec-format-characters (make-vector 67 0))
+
+
+(defun common-lisp-hyperspec-section-6.0 (indices)
+ (let ((string (format "%sBody/%s_"
+ common-lisp-hyperspec-root
+ (let ((base (pop indices)))
+ (if (< base 10)
+ (format "0%s" base)
+ base)))))
+ (concat string
+ (mapconcat (lambda (n)
+ (make-string 1 (+ ?a (- n 1))))
+ indices
+ "")
+ ".htm")))
+
+(defun common-lisp-hyperspec-section-4.0 (indices)
+ (let ((string (format "%sBody/sec_"
+ common-lisp-hyperspec-root)))
+ (concat string
+ (mapconcat (lambda (n)
+ (format "%d" n))
+ indices
+ "-")
+ ".html")))
+
+(defvar common-lisp-hyperspec-section-fun 'common-lisp-hyperspec-section-6.0)
+
+(defun common-lisp-hyperspec-section (indices)
+ (funcall common-lisp-hyperspec-section-fun indices))
+
+(defun common-lisp-hyperspec-format (character-name)
+ (interactive
+ (list (let ((char-at-point
+ (ignore-errors (char-to-string (char-after (point))))))
+ (if (and char-at-point
+ (intern-soft (upcase char-at-point)
+ common-lisp-hyperspec-format-characters))
+ char-at-point
+ (completing-read
+ "Look up format control character in Common Lisp HyperSpec: "
+ common-lisp-hyperspec-format-characters nil #'boundp
+ nil nil 'common-lisp-hyperspec-format-history)))))
+ (maplist (lambda (entry)
+ (browse-url (common-lisp-hyperspec-section (car entry))))
+ (let ((symbol (intern-soft character-name
+ common-lisp-hyperspec-format-characters)))
+ (if (and symbol (boundp symbol))
+ (symbol-value symbol)
+ (error "The symbol `%s' is not defined in Common Lisp"
+ character-name)))))
+
+(eval-when (load eval)
+ (defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format))
+
+(mapcar (lambda (entry)
+ (let ((symbol (intern (car entry)
+ common-lisp-hyperspec-format-characters)))
+ (if (boundp symbol)
+ (pushnew (cadr entry) (symbol-value symbol) :test 'equal)
+ (set symbol (cdr entry))))
+ (when (and (= 1 (length (car entry)))
+ (not (string-equal (car entry) (upcase (car entry)))))
+ (let ((symbol (intern (upcase (car entry))
+ common-lisp-hyperspec-format-characters)))
+ (if (boundp symbol)
+ (pushnew (cadr entry) (symbol-value symbol) :test 'equal)
+ (set symbol (cdr entry))))))
+ '(("c" (22 3 1 1)) ("C: Character" (22 3 1 1))
+ ("%" (22 3 1 2)) ("Percent: Newline" (22 3 1 2))
+ ("&" (22 3 1 3)) ("Ampersand: Fresh-line" (22 3 1 3))
+ ("|" (22 3 1 4)) ("Vertical-Bar: Page" (22 3 1 4))
+ ("~" (22 3 1 5)) ("Tilde: Tilde" (22 3 1 5))
+ ("r" (22 3 2 1)) ("R: Radix" (22 3 2 1))
+ ("d" (22 3 2 2)) ("D: Decimal" (22 3 2-2))
+ ("b" (22 3 2 3)) ("B: Binary" (22 3 2 3))
+ ("o" (22 3 2 4)) ("O: Octal" (22 3 2 4))
+ ("x" (22 3 2 5)) ("X: Hexadecimal" (22 3 2 5))
+ ("f" (22 3 3 1)) ("F: Fixed-Format Floating-Point" (22 3 3 1))
+ ("e" (22 3 3 2)) ("E: Exponential Floating-Point" (22 3 3 2))
+ ("g" (22 3 3 3)) ("G: General Floating-Point" (22 3 3 3))
+ ("$" (22 3 3 4)) ("Dollarsign: Monetary Floating-Point" (22 3 3 4))
+ ("a" (22 3 4 1)) ("A: Aesthetic" (22 3 4 1))
+ ("s" (22 3 4 2)) ("S: Standard" (22 3 4 2))
+ ("w" (22 3 4 3)) ("W: Write" (22 3 4 3))
+ ("_" (22 3 5 1)) ("Underscore: Conditional Newline" (22 3 5 1))
+ ("<" (22 3 5 2)) ("Less-Than-Sign: Logical Block" (22 3 5 2))
+ ("i" (22 3 5 3)) ("I: Indent" (22 3 5 3))
+ ("/" (22 3 5 4)) ("Slash: Call Function" (22 3 5 4))
+ ("t" (22 3 6 1)) ("T: Tabulate" (22 3 6 1))
+ ("<" (22 3 6 2)) ("Less-Than-Sign: Justification" (22 3 6 2))
+ (">" (22 3 6 3)) ("Greater-Than-Sign: End of Justification" (22 3 6 3))
+ ("*" (22 3 7 1)) ("Asterisk: Go-To" (22 3 7 1))
+ ("[" (22 3 7 2)) ("Left-Bracket: Conditional Expression" (22 3 7 2))
+ ("]" (22 3 7 3)) ("Right-Bracket: End of Conditional Expression" (22 3 7 3))
+ ("{" (22 3 7 4)) ("Left-Brace: Iteration" (22 3 7 4))
+ ("}" (22 3 7 5)) ("Right-Brace: End of Iteration" (22 3 7 5))
+ ("?" (22 3 7 6)) ("Question-Mark: Recursive Processing" (22 3 7 6))
+ ("(" (22 3 8 1)) ("Left-Paren: Case Conversion" (22 3 8 1))
+ (")" (22 3 8 2)) ("Right-Paren: End of Case Conversion" (22 3 8 2))
+ ("p" (22 3 8 3)) ("P: Plural" (22 3 8-3))
+ (";" (22 3 9 1)) ("Semicolon: Clause Separator" (22 3 9 1))
+ ("^" (22 3 9 2)) ("Circumflex: Escape Upward" (22 3 9 2))
+ ("Newline: Ignored Newline" (22 3 9 3))
+ ("Nesting of FORMAT Operations" (22 3 10 1))
+ ("Missing and Additional FORMAT Arguments" (22 3 10 2))
+ ("Additional FORMAT Parameters" (22 3 10 3))))
+
+(defvar common-lisp-glossary-fun 'common-lisp-glossary-6.0)
+
+(defun common-lisp-glossary-6.0 (string)
+ (format "%sBody/26_glo_%s.htm#%s"
+ common-lisp-hyperspec-root
+ (let ((char (string-to-char string)))
+ (if (and (<= ?a char)
+ (<= char ?z))
+ (make-string 1 char)
+ "9"))
+ (subst-char-in-string ?\ ?_ string)))
+
+(defun common-lisp-glossary-4.0 (string)
+ (format "%sBody/glo_%s.html#%s"
+ common-lisp-hyperspec-root
+ (let ((char (string-to-char string)))
+ (if (and (<= ?a char)
+ (<= char ?z))
+ (make-string 1 char)
+ "9"))
+ (subst-char-in-string ?\ ?_ string)))
+
+(defvar common-lisp-hyperspec-issuex-table nil
+ "The HyperSpec IssueX table file. If you copy the HyperSpec to your
+local system, set this variable to the location of the Issue
+cross-references table which is usually \"Map_IssX.txt\" or
+\"Issue-Cross-Refs.text\".")
+
+(defvar common-lisp-hyperspec-issuex-symbols (make-vector 67 0))
+
+(if common-lisp-hyperspec-issuex-table
+ (let ((index-buffer (find-file-noselect common-lisp-hyperspec-issuex-table)))
+ (labels ((get-one-line ()
+ (prog1
+ (delete* ?\n (thing-at-point 'line))
+ (forward-line))))
+ (save-excursion
+ (set-buffer index-buffer)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (let* ((symbol (intern (downcase (get-one-line))
+ common-lisp-hyperspec-issuex-symbols))
+ (relative-url (get-one-line)))
+ (set symbol (subseq relative-url
+ (1+ (position ?\/ relative-url :from-end t)))))))))
+ (mapcar
+ (lambda (entry)
+ (let ((symbol (intern (car entry) common-lisp-hyperspec-issuex-symbols)))
+ (set symbol (cadr entry))))
+ '(("&environment-binding-order:first" "iss001.htm")
+ ("access-error-name" "iss002.htm")
+ ("adjust-array-displacement" "iss003.htm")
+ ("adjust-array-fill-pointer" "iss004.htm")
+ ("adjust-array-not-adjustable:implicit-copy" "iss005.htm")
+ ("allocate-instance:add" "iss006.htm")
+ ("allow-local-inline:inline-notinline" "iss007.htm")
+ ("allow-other-keys-nil:permit" "iss008.htm")
+ ("aref-1d" "iss009.htm")
+ ("argument-mismatch-error-again:consistent" "iss010.htm")
+ ("argument-mismatch-error-moon:fix" "iss011.htm")
+ ("argument-mismatch-error:more-clarifications" "iss012.htm")
+ ("arguments-underspecified:specify" "iss013.htm")
+ ("array-dimension-limit-implications:all-fixnum" "iss014.htm")
+ ("array-type-element-type-semantics:unify-upgrading" "iss015.htm")
+ ("assert-error-type:error" "iss016.htm")
+ ("assoc-rassoc-if-key" "iss017.htm")
+ ("assoc-rassoc-if-key:yes" "iss018.htm")
+ ("boa-aux-initialization:error-on-read" "iss019.htm")
+ ("break-on-warnings-obsolete:remove" "iss020.htm")
+ ("broadcast-stream-return-values:clarify-minimally" "iss021.htm")
+ ("butlast-negative:should-signal" "iss022.htm")
+ ("change-class-initargs:permit" "iss023.htm")
+ ("char-name-case:x3j13-mar-91" "iss024.htm")
+ ("character-loose-ends:fix" "iss025.htm")
+ ("character-proposal:2" "iss026.htm")
+ ("character-proposal:2-1-1" "iss027.htm")
+ ("character-proposal:2-1-2" "iss028.htm")
+ ("character-proposal:2-2-1" "iss029.htm")
+ ("character-proposal:2-3-1" "iss030.htm")
+ ("character-proposal:2-3-2" "iss031.htm")
+ ("character-proposal:2-3-3" "iss032.htm")
+ ("character-proposal:2-3-4" "iss033.htm")
+ ("character-proposal:2-3-5" "iss034.htm")
+ ("character-proposal:2-3-6" "iss035.htm")
+ ("character-proposal:2-4-1" "iss036.htm")
+ ("character-proposal:2-4-2" "iss037.htm")
+ ("character-proposal:2-4-3" "iss038.htm")
+ ("character-proposal:2-5-2" "iss039.htm")
+ ("character-proposal:2-5-6" "iss040.htm")
+ ("character-proposal:2-5-7" "iss041.htm")
+ ("character-proposal:2-6-1" "iss042.htm")
+ ("character-proposal:2-6-2" "iss043.htm")
+ ("character-proposal:2-6-3" "iss044.htm")
+ ("character-proposal:2-6-5" "iss045.htm")
+ ("character-vs-char:less-inconsistent-short" "iss046.htm")
+ ("class-object-specializer:affirm" "iss047.htm")
+ ("clos-conditions-again:allow-subset" "iss048.htm")
+ ("clos-conditions:integrate" "iss049.htm")
+ ("clos-error-checking-order:no-applicable-method-first" "iss050.htm")
+ ("clos-macro-compilation:minimal" "iss051.htm")
+ ("close-constructed-stream:argument-stream-only" "iss052.htm")
+ ("closed-stream-operations:allow-inquiry" "iss053.htm")
+ ("coercing-setf-name-to-function:all-function-names" "iss054.htm")
+ ("colon-number" "iss055.htm")
+ ("common-features:specify" "iss056.htm")
+ ("common-type:remove" "iss057.htm")
+ ("compile-argument-problems-again:fix" "iss058.htm")
+ ("compile-file-handling-of-top-level-forms:clarify" "iss059.htm")
+ ("compile-file-output-file-defaults:input-file" "iss060.htm")
+ ("compile-file-package" "iss061.htm")
+ ("compile-file-pathname-arguments:make-consistent" "iss062.htm")
+ ("compile-file-symbol-handling:new-require-consistency" "iss063.htm")
+ ("compiled-function-requirements:tighten" "iss064.htm")
+ ("compiler-diagnostics:use-handler" "iss065.htm")
+ ("compiler-let-confusion:eliminate" "iss066.htm")
+ ("compiler-verbosity:like-load" "iss067.htm")
+ ("compiler-warning-stream" "iss068.htm")
+ ("complex-atan-branch-cut:tweak" "iss069.htm")
+ ("complex-atanh-bogus-formula:tweak-more" "iss070.htm")
+ ("complex-rational-result:extend" "iss071.htm")
+ ("compute-applicable-methods:generic" "iss072.htm")
+ ("concatenate-sequence:signal-error" "iss073.htm")
+ ("condition-accessors-setfable:no" "iss074.htm")
+ ("condition-restarts:buggy" "iss075.htm")
+ ("condition-restarts:permit-association" "iss076.htm")
+ ("condition-slots:hidden" "iss077.htm")
+ ("cons-type-specifier:add" "iss078.htm")
+ ("constant-circular-compilation:yes" "iss079.htm")
+ ("constant-collapsing:generalize" "iss080.htm")
+ ("constant-compilable-types:specify" "iss081.htm")
+ ("constant-function-compilation:no" "iss082.htm")
+ ("constant-modification:disallow" "iss083.htm")
+ ("constantp-definition:intentional" "iss084.htm")
+ ("constantp-environment:add-arg" "iss085.htm")
+ ("contagion-on-numerical-comparisons:transitive" "iss086.htm")
+ ("copy-symbol-copy-plist:copy-list" "iss087.htm")
+ ("copy-symbol-print-name:equal" "iss088.htm")
+ ("data-io:add-support" "iss089.htm")
+ ("data-types-hierarchy-underspecified" "iss090.htm")
+ ("debugger-hook-vs-break:clarify" "iss091.htm")
+ ("declaration-scope:no-hoisting" "iss092.htm")
+ ("declare-array-type-element-references:restrictive" "iss093.htm")
+ ("declare-function-ambiguity:delete-ftype-abbreviation" "iss094.htm")
+ ("declare-macros:flush" "iss095.htm")
+ ("declare-type-free:lexical" "iss096.htm")
+ ("decls-and-doc" "iss097.htm")
+ ("decode-universal-time-daylight:like-encode" "iss098.htm")
+ ("defconstant-special:no" "iss099.htm")
+ ("defgeneric-declare:allow-multiple" "iss100.htm")
+ ("define-compiler-macro:x3j13-nov89" "iss101.htm")
+ ("define-condition-syntax:incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm")
+ ("define-method-combination-behavior:clarify" "iss103.htm")
+ ("defining-macros-non-top-level:allow" "iss104.htm")
+ ("defmacro-block-scope:excludes-bindings" "iss105.htm")
+ ("defmacro-lambda-list:tighten-description" "iss106.htm")
+ ("defmethod-declaration-scope:corresponds-to-bindings" "iss107.htm")
+ ("defpackage:addition" "iss108.htm")
+ ("defstruct-constructor-key-mixture:allow-key" "iss109.htm")
+ ("defstruct-constructor-options:explicit" "iss110.htm")
+ ("defstruct-constructor-slot-variables:not-bound" "iss111.htm")
+ ("defstruct-copier-argument-type:restrict" "iss112.htm")
+ ("defstruct-copier:argument-type" "iss113.htm")
+ ("defstruct-default-value-evaluation:iff-needed" "iss114.htm")
+ ("defstruct-include-deftype:explicitly-undefined" "iss115.htm")
+ ("defstruct-print-function-again:x3j13-mar-93" "iss116.htm")
+ ("defstruct-print-function-inheritance:yes" "iss117.htm")
+ ("defstruct-redefinition:error" "iss118.htm")
+ ("defstruct-slots-constraints-name:duplicates-error" "iss119.htm")
+ ("defstruct-slots-constraints-number" "iss120.htm")
+ ("deftype-destructuring:yes" "iss121.htm")
+ ("deftype-key:allow" "iss122.htm")
+ ("defvar-documentation:unevaluated" "iss123.htm")
+ ("defvar-init-time:not-delayed" "iss124.htm")
+ ("defvar-initialization:conservative" "iss125.htm")
+ ("deprecation-position:limited" "iss126.htm")
+ ("describe-interactive:no" "iss127.htm")
+ ("describe-underspecified:describe-object" "iss128.htm")
+ ("destructive-operations:specify" "iss129.htm")
+ ("destructuring-bind:new-macro" "iss130.htm")
+ ("disassemble-side-effect:do-not-install" "iss131.htm")
+ ("displaced-array-predicate:add" "iss132.htm")
+ ("do-symbols-block-scope:entire-form" "iss133.htm")
+ ("do-symbols-duplicates" "iss134.htm")
+ ("documentation-function-bugs:fix" "iss135.htm")
+ ("documentation-function-tangled:require-argument" "iss136.htm")
+ ("dotimes-ignore:x3j13-mar91" "iss137.htm")
+ ("dotted-list-arguments:clarify" "iss138.htm")
+ ("dotted-macro-forms:allow" "iss139.htm")
+ ("dribble-technique" "iss140.htm")
+ ("dynamic-extent-function:extend" "iss141.htm")
+ ("dynamic-extent:new-declaration" "iss142.htm")
+ ("equal-structure:maybe-status-quo" "iss143.htm")
+ ("error-terminology-warning:might" "iss144.htm")
+ ("eval-other:self-evaluate" "iss145.htm")
+ ("eval-top-level:load-like-compile-file" "iss146.htm")
+ ("eval-when-non-top-level:generalize-eval-new-keywords" "iss147.htm")
+ ("eval-when-obsolete-keywords:x3j13-mar-1993" "iss148.htm")
+ ("evalhook-step-confusion:fix" "iss149.htm")
+ ("evalhook-step-confusion:x3j13-nov-89" "iss150.htm")
+ ("exit-extent-and-condition-system:like-dynamic-bindings" "iss151.htm")
+ ("exit-extent:minimal" "iss152.htm")
+ ("expt-ratio:p.211" "iss153.htm")
+ ("extensions-position:documentation" "iss154.htm")
+ ("external-format-for-every-file-connection:minimum" "iss155.htm")
+ ("extra-return-values:no" "iss156.htm")
+ ("file-open-error:signal-file-error" "iss157.htm")
+ ("fixnum-non-portable:tighten-definition" "iss158.htm")
+ ("flet-declarations" "iss159.htm")
+ ("flet-declarations:allow" "iss160.htm")
+ ("flet-implicit-block:yes" "iss161.htm")
+ ("float-underflow:add-variables" "iss162.htm")
+ ("floating-point-condition-names:x3j13-nov-89" "iss163.htm")
+ ("format-atsign-colon" "iss164.htm")
+ ("format-colon-uparrow-scope" "iss165.htm")
+ ("format-comma-interval" "iss166.htm")
+ ("format-e-exponent-sign:force-sign" "iss167.htm")
+ ("format-op-c" "iss168.htm")
+ ("format-pretty-print:yes" "iss169.htm")
+ ("format-string-arguments:specify" "iss170.htm")
+ ("function-call-evaluation-order:more-unspecified" "iss171.htm")
+ ("function-composition:jan89-x3j13" "iss172.htm")
+ ("function-definition:jan89-x3j13" "iss173.htm")
+ ("function-name:large" "iss174.htm")
+ ("function-type" "iss175.htm")
+ ("function-type-argument-type-semantics:restrictive" "iss176.htm")
+ ("function-type-key-name:specify-keyword" "iss177.htm")
+ ("function-type-rest-list-element:use-actual-argument-type" "iss178.htm")
+ ("function-type:x3j13-march-88" "iss179.htm")
+ ("generalize-pretty-printer:unify" "iss180.htm")
+ ("generic-flet-poorly-designed:delete" "iss181.htm")
+ ("gensym-name-stickiness:like-teflon" "iss182.htm")
+ ("gentemp-bad-idea:deprecate" "iss183.htm")
+ ("get-macro-character-readtable:nil-standard" "iss184.htm")
+ ("get-setf-method-environment:add-arg" "iss185.htm")
+ ("hash-table-access:x3j13-mar-89" "iss186.htm")
+ ("hash-table-key-modification:specify" "iss187.htm")
+ ("hash-table-package-generators:add-with-wrapper" "iss188.htm")
+ ("hash-table-rehash-size-integer" "iss189.htm")
+ ("hash-table-size:intended-entries" "iss190.htm")
+ ("hash-table-tests:add-equalp" "iss191.htm")
+ ("ieee-atan-branch-cut:split" "iss192.htm")
+ ("ignore-use-terminology:value-only" "iss193.htm")
+ ("import-setf-symbol-package" "iss194.htm")
+ ("in-package-functionality:mar89-x3j13" "iss195.htm")
+ ("in-syntax:minimal" "iss196.htm")
+ ("initialization-function-keyword-checking" "iss197.htm")
+ ("iso-compatibility:add-substrate" "iss198.htm")
+ ("jun90-trivial-issues:11" "iss199.htm")
+ ("jun90-trivial-issues:14" "iss200.htm")
+ ("jun90-trivial-issues:24" "iss201.htm")
+ ("jun90-trivial-issues:25" "iss202.htm")
+ ("jun90-trivial-issues:27" "iss203.htm")
+ ("jun90-trivial-issues:3" "iss204.htm")
+ ("jun90-trivial-issues:4" "iss205.htm")
+ ("jun90-trivial-issues:5" "iss206.htm")
+ ("jun90-trivial-issues:9" "iss207.htm")
+ ("keyword-argument-name-package:any" "iss208.htm")
+ ("last-n" "iss209.htm")
+ ("lcm-no-arguments:1" "iss210.htm")
+ ("lexical-construct-global-definition:undefined" "iss211.htm")
+ ("lisp-package-name:common-lisp" "iss212.htm")
+ ("lisp-symbol-redefinition-again:more-fixes" "iss213.htm")
+ ("lisp-symbol-redefinition:mar89-x3j13" "iss214.htm")
+ ("load-objects:make-load-form" "iss215.htm")
+ ("load-time-eval:r**2-new-special-form" "iss216.htm")
+ ("load-time-eval:r**3-new-special-form" "iss217.htm")
+ ("load-truename:new-pathname-variables" "iss218.htm")
+ ("locally-top-level:special-form" "iss219.htm")
+ ("loop-and-discrepancy:no-reiteration" "iss220.htm")
+ ("loop-for-as-on-typo:fix-typo" "iss221.htm")
+ ("loop-initform-environment:partial-interleaving-vague" "iss222.htm")
+ ("loop-miscellaneous-repairs:fix" "iss223.htm")
+ ("loop-named-block-nil:override" "iss224.htm")
+ ("loop-present-symbols-typo:flush-wrong-words" "iss225.htm")
+ ("loop-syntax-overhaul:repair" "iss226.htm")
+ ("macro-as-function:disallow" "iss227.htm")
+ ("macro-declarations:make-explicit" "iss228.htm")
+ ("macro-environment-extent:dynamic" "iss229.htm")
+ ("macro-function-environment" "iss230.htm")
+ ("macro-function-environment:yes" "iss231.htm")
+ ("macro-subforms-top-level-p:add-constraints" "iss232.htm")
+ ("macroexpand-hook-default:explicitly-vague" "iss233.htm")
+ ("macroexpand-hook-initial-value:implementation-dependent" "iss234.htm")
+ ("macroexpand-return-value:true" "iss235.htm")
+ ("make-load-form-confusion:rewrite" "iss236.htm")
+ ("make-load-form-saving-slots:no-initforms" "iss237.htm")
+ ("make-package-use-default:implementation-dependent" "iss238.htm")
+ ("map-into:add-function" "iss239.htm")
+ ("mapping-destructive-interaction:explicitly-vague" "iss240.htm")
+ ("metaclass-of-system-class:unspecified" "iss241.htm")
+ ("method-combination-arguments:clarify" "iss242.htm")
+ ("method-initform:forbid-call-next-method" "iss243.htm")
+ ("muffle-warning-condition-argument" "iss244.htm")
+ ("multiple-value-setq-order:like-setf-of-values" "iss245.htm")
+ ("multiple-values-limit-on-variables:undefined" "iss246.htm")
+ ("nintersection-destruction" "iss247.htm")
+ ("nintersection-destruction:revert" "iss248.htm")
+ ("not-and-null-return-value:x3j13-mar-93" "iss249.htm")
+ ("nth-value:add" "iss250.htm")
+ ("optimize-debug-info:new-quality" "iss251.htm")
+ ("package-clutter:reduce" "iss252.htm")
+ ("package-deletion:new-function" "iss253.htm")
+ ("package-function-consistency:more-permissive" "iss254.htm")
+ ("parse-error-stream:split-types" "iss255.htm")
+ ("pathname-component-case:keyword-argument" "iss256.htm")
+ ("pathname-component-value:specify" "iss257.htm")
+ ("pathname-host-parsing:recognize-logical-host-names" "iss258.htm")
+ ("pathname-logical:add" "iss259.htm")
+ ("pathname-print-read:sharpsign-p" "iss260.htm")
+ ("pathname-stream" "iss261.htm")
+ ("pathname-stream:files-or-synonym" "iss262.htm")
+ ("pathname-subdirectory-list:new-representation" "iss263.htm")
+ ("pathname-symbol" "iss264.htm")
+ ("pathname-syntax-error-time:explicitly-vague" "iss265.htm")
+ ("pathname-unspecific-component:new-token" "iss266.htm")
+ ("pathname-wild:new-functions" "iss267.htm")
+ ("peek-char-read-char-echo:first-read-char" "iss268.htm")
+ ("plist-duplicates:allow" "iss269.htm")
+ ("pretty-print-interface" "iss270.htm")
+ ("princ-readably:x3j13-dec-91" "iss271.htm")
+ ("print-case-behavior:clarify" "iss272.htm")
+ ("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" "iss273.htm")
+ ("print-circle-shared:respect-print-circle" "iss274.htm")
+ ("print-circle-structure:user-functions-work" "iss275.htm")
+ ("print-readably-behavior:clarify" "iss276.htm")
+ ("printer-whitespace:just-one-space" "iss277.htm")
+ ("proclaim-etc-in-compile-file:new-macro" "iss278.htm")
+ ("push-evaluation-order:first-item" "iss279.htm")
+ ("push-evaluation-order:item-first" "iss280.htm")
+ ("pushnew-store-required:unspecified" "iss281.htm")
+ ("quote-semantics:no-copying" "iss282.htm")
+ ("range-of-count-keyword:nil-or-integer" "iss283.htm")
+ ("range-of-start-and-end-parameters:integer-and-integer-nil" "iss284.htm")
+ ("read-and-write-bytes:new-functions" "iss285.htm")
+ ("read-case-sensitivity:readtable-keywords" "iss286.htm")
+ ("read-modify-write-evaluation-order:delayed-access-stores" "iss287.htm")
+ ("read-suppress-confusing:generalize" "iss288.htm")
+ ("reader-error:new-type" "iss289.htm")
+ ("real-number-type:x3j13-mar-89" "iss290.htm")
+ ("recursive-deftype:explicitly-vague" "iss291.htm")
+ ("reduce-argument-extraction" "iss292.htm")
+ ("remf-destruction-unspecified:x3j13-mar-89" "iss293.htm")
+ ("require-pathname-defaults-again:x3j13-dec-91" "iss294.htm")
+ ("require-pathname-defaults-yet-again:restore-argument" "iss295.htm")
+ ("require-pathname-defaults:eliminate" "iss296.htm")
+ ("rest-list-allocation:may-share" "iss297.htm")
+ ("result-lists-shared:specify" "iss298.htm")
+ ("return-values-unspecified:specify" "iss299.htm")
+ ("room-default-argument:new-value" "iss300.htm")
+ ("self-modifying-code:forbid" "iss301.htm")
+ ("sequence-type-length:must-match" "iss302.htm")
+ ("setf-apply-expansion:ignore-expander" "iss303.htm")
+ ("setf-find-class:allow-nil" "iss304.htm")
+ ("setf-functions-again:minimal-changes" "iss305.htm")
+ ("setf-get-default:evaluated-but-ignored" "iss306.htm")
+ ("setf-macro-expansion:last" "iss307.htm")
+ ("setf-method-vs-setf-method:rename-old-terms" "iss308.htm")
+ ("setf-multiple-store-variables:allow" "iss309.htm")
+ ("setf-of-apply:only-aref-and-friends" "iss310.htm")
+ ("setf-of-values:add" "iss311.htm")
+ ("setf-sub-methods:delayed-access-stores" "iss312.htm")
+ ("shadow-already-present" "iss313.htm")
+ ("shadow-already-present:works" "iss314.htm")
+ ("sharp-comma-confusion:remove" "iss315.htm")
+ ("sharp-o-foobar:consequences-undefined" "iss316.htm")
+ ("sharp-star-delimiter:normal-delimiter" "iss317.htm")
+ ("sharpsign-plus-minus-package:keyword" "iss318.htm")
+ ("slot-missing-values:specify" "iss319.htm")
+ ("slot-value-metaclasses:less-minimal" "iss320.htm")
+ ("special-form-p-misnomer:rename" "iss321.htm")
+ ("special-type-shadowing:clarify" "iss322.htm")
+ ("standard-input-initial-binding:defined-contracts" "iss323.htm")
+ ("standard-repertoire-gratuitous:rename" "iss324.htm")
+ ("step-environment:current" "iss325.htm")
+ ("step-minimal:permit-progn" "iss326.htm")
+ ("stream-access:add-types-accessors" "iss327.htm")
+ ("stream-capabilities:interactive-stream-p" "iss328.htm")
+ ("string-coercion:make-consistent" "iss329.htm")
+ ("string-output-stream-bashing:undefined" "iss330.htm")
+ ("structure-read-print-syntax:keywords" "iss331.htm")
+ ("subseq-out-of-bounds" "iss332.htm")
+ ("subseq-out-of-bounds:is-an-error" "iss333.htm")
+ ("subsetting-position:none" "iss334.htm")
+ ("subtypep-environment:add-arg" "iss335.htm")
+ ("subtypep-too-vague:clarify-more" "iss336.htm")
+ ("sxhash-definition:similar-for-sxhash" "iss337.htm")
+ ("symbol-macrolet-declare:allow" "iss338.htm")
+ ("symbol-macrolet-semantics:special-form" "iss339.htm")
+ ("symbol-macrolet-type-declaration:no" "iss340.htm")
+ ("symbol-macros-and-proclaimed-specials:signals-an-error" "iss341.htm")
+ ("symbol-print-escape-behavior:clarify" "iss342.htm")
+ ("syntactic-environment-access:retracted-mar91" "iss343.htm")
+ ("tagbody-tag-expansion:no" "iss344.htm")
+ ("tailp-nil:t" "iss345.htm")
+ ("test-not-if-not:flush-all" "iss346.htm")
+ ("the-ambiguity:for-declaration" "iss347.htm")
+ ("the-values:return-number-received" "iss348.htm")
+ ("time-zone-non-integer:allow" "iss349.htm")
+ ("type-declaration-abbreviation:allow-all" "iss350.htm")
+ ("type-of-and-predefined-classes:type-of-handles-floats" "iss351.htm")
+ ("type-of-and-predefined-classes:unify-and-extend" "iss352.htm")
+ ("type-of-underconstrained:add-constraints" "iss353.htm")
+ ("type-specifier-abbreviation:x3j13-jun90-guess" "iss354.htm")
+ ("undefined-variables-and-functions:compromise" "iss355.htm")
+ ("uninitialized-elements:consequences-undefined" "iss356.htm")
+ ("unread-char-after-peek-char:dont-allow" "iss357.htm")
+ ("unsolicited-messages:not-to-system-user-streams" "iss358.htm")
+ ("variable-list-asymmetry:symmetrize" "iss359.htm")
+ ("with-added-methods:delete" "iss360.htm")
+ ("with-compilation-unit:new-macro" "iss361.htm")
+ ("with-open-file-does-not-exist:stream-is-nil" "iss362.htm")
+ ("with-open-file-setq:explicitly-vague" "iss363.htm")
+ ("with-open-file-stream-extent:dynamic-extent" "iss364.htm")
+ ("with-output-to-string-append-style:vector-push-extend" "iss365.htm")
+ ("with-standard-io-syntax-readtable:x3j13-mar-91" "iss366.htm"))))
+
+(defun common-lisp-issuex (issue-name)
+ (let ((symbol
+ (intern (downcase issue-name) common-lisp-hyperspec-issuex-symbols)))
+ (concat common-lisp-hyperspec-root "Issues/" (symbol-value symbol))))
+
+(provide 'hyperspec)
+
+;;; hyperspec.el ends here
Added: branches/bos/thirdparty/emacs/slime/metering.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/metering.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,1222 @@
+;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*-
+;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant(a)GLINDA.OZ.CS.CMU.EDU>
+
+;;; ****************************************************************
+;;; Metering System ************************************************
+;;; ****************************************************************
+;;;
+;;; The Metering System is a portable Common Lisp code profiling tool.
+;;; It gathers timing and consing statistics for specified functions
+;;; while a program is running.
+;;;
+;;; The Metering System is a combination of
+;;; o the Monitor package written by Chris McConnell
+;;; o the Profile package written by Skef Wholey and Rob MacLachlan
+;;; The two systems were merged and extended by Mark Kantrowitz.
+;;;
+;;; Address: Carnegie Mellon University
+;;; School of Computer Science
+;;; Pittsburgh, PA 15213
+;;;
+;;; This code is in the public domain and is distributed without warranty
+;;; of any kind.
+;;;
+;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/
+;;;
+;;;
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages.
+;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics
+;;; with respect to nested calls. (Allows it to subtract
+;;; total monitoring overhead for each function, not just
+;;; the time spent monitoring the function itself.)
+;;; 26-JUN-90 mk The table is now saved so that one may manipulate
+;;; the data (sorting it, etc.) even after the original
+;;; source of the data has been cleared.
+;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2
+;;; required-arguments functions for Lucid 3.0,
+;;; Franz Allegro CL, and MACL 1.3.2.
+;;; 25-JAN-91 mk Now uses fdefinition if available.
+;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl.
+;;; Much better solution for the fact that both call
+;;; themselves :allegro.
+;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded
+;;; uncompiled.
+;;; 5-JUL-91 mk When many unmonitored functions, print out number
+;;; instead of whole list.
+;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring
+;;; doesn't work in MCL, but fixed so that timing
+;;; statistics do.
+;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with
+;;; (and :ccl (not :lispworks)).
+;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0.
+;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1,
+;;; Lucid 4.0, ibcl
+;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible.
+;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL.
+;;; Purely to cut down on stale code (e.g. #+cltl2) in this
+;;; version that is bundled with SLIME.
+;;;
+;;;
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;; - Need get-cons for Allegro, AKCL.
+;;; - Speed up monitoring code. Replace use of hash tables with an embedded
+;;; offset in an array so that it will be faster than using gethash.
+;;; (i.e., svref/closure reference is usually faster than gethash).
+;;; - Beware of (get-internal-run-time) overflowing. Yikes!
+;;; - Check robustness with respect to profiled functions.
+;;; - Check logic of computing inclusive and exclusive time and consing.
+;;; Especially wrt incf/setf comment below. Should be incf, so we
+;;; sum recursive calls.
+;;; - Add option to record caller statistics -- this would list who
+;;; called which functions and how often.
+;;; - switches to turn timing/CONSING statistics collection on/off.
+
+
+;;; ********************************
+;;; Notes **************************
+;;; ********************************
+;;;
+;;; METERING has been tested (successfully) in the following lisps:
+;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler
+;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
+;;; Macintosh Allegro Common Lisp (1.3.2)
+;;; Macintosh Common Lisp (2.0)
+;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1
+;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0
+;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1
+;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1
+;;; Lucid CL (Version 2.1 6-DEC-87)
+;;; Lucid Common Lisp (3.0)
+;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91)
+;;; AKCL (1.86, June 30, 1987 or later)
+;;; Ibuki Common Lisp (Version 2, release 01.027)
+;;; CLISP (January 1994)
+;;;
+;;; METERING needs to be tested in the following lisps:
+;;; Symbolics Common Lisp (8.0)
+;;; KCL (June 3, 1987 or later)
+;;; TI (Release 4.1 or later)
+;;; Golden Common Lisp (3.1 IBM-PC)
+;;; VAXLisp (2.0, 3.1)
+;;; Procyon Common Lisp
+
+
+;;; ****************************************************************
+;;; Documentation **************************************************
+;;; ****************************************************************
+;;;
+;;; This system runs in any valid Common Lisp. Four small
+;;; implementation-dependent changes can be made to improve performance
+;;; and prettiness. In the section labelled "Implementation Dependent
+;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS,
+;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation
+;;; for the best results. If GET-CONS is not specified for your
+;;; implementation, no consing information will be reported. The other
+;;; functions will default to working forms, albeit inefficient, in
+;;; non-CMU implementations. If you tailor these functions for a particular
+;;; version of Common Lisp, we'd appreciate receiving the code.
+;;;
+
+;;; ****************************************************************
+;;; Usage Notes ****************************************************
+;;; ****************************************************************
+;;;
+;;; SUGGESTED USAGE:
+;;;
+;;; Start by monitoring big pieces of the program, then carefully choose
+;;; which functions close to, but not in, the inner loop are to be
+;;; monitored next. Don't monitor functions that are called by other
+;;; monitored functions: you will only confuse yourself.
+;;;
+;;; If the per-call time reported is less than 1/10th of a second, then
+;;; consider the clock resolution and profiling overhead before you believe
+;;; the time. It may be that you will need to run your program many times
+;;; in order to average out to a higher resolution.
+;;;
+;;; The easiest way to use this package is to load it and execute either
+;;; (mon:with-monitoring (names*) ()
+;;; your-forms*)
+;;; or
+;;; (mon:monitor-form your-form)
+;;; The former allows you to specify which functions will be monitored; the
+;;; latter monitors all functions in the current package. Both automatically
+;;; produce a table of statistics. Other variants can be constructed from
+;;; the monitoring primitives, which are described below, along with a
+;;; fuller description of these two macros.
+;;;
+;;; For best results, compile this file before using.
+;;;
+;;;
+;;; CLOCK RESOLUTION:
+;;;
+;;; Unless you are very lucky, the length of your machine's clock "tick" is
+;;; probably much longer than the time it takes a simple function to run.
+;;; For example, on the IBM RT, the clock resolution is 1/50th of a second.
+;;; This means that if a function is only called a few times, then only the
+;;; first couple of decimal places are really meaningful.
+;;;
+;;;
+;;; MONITORING OVERHEAD:
+;;;
+;;; The added monitoring code takes time to run every time that the monitored
+;;; function is called, which can disrupt the attempt to collect timing
+;;; information. In order to avoid serious inflation of the times for functions
+;;; that take little time to run, an estimate of the overhead due to monitoring
+;;; is subtracted from the times reported for each function.
+;;;
+;;; Although this correction works fairly well, it is not totally accurate,
+;;; resulting in times that become increasingly meaningless for functions
+;;; with short runtimes. For example, subtracting the estimated overhead
+;;; may result in negative times for some functions. This is only a concern
+;;; when the estimated profiling overhead is many times larger than
+;;; reported total CPU time.
+;;;
+;;; If you monitor functions that are called by monitored functions, in
+;;; :inclusive mode the monitoring overhead for the inner function is
+;;; subtracted from the CPU time for the outer function. [We do this by
+;;; counting for each function not only the number of calls to *this*
+;;; function, but also the number of monitored calls while it was running.]
+;;; In :exclusive mode this is not necessary, since we subtract the
+;;; monitoring time of inner functions, overhead & all.
+;;;
+;;; Otherwise, the estimated monitoring overhead is not represented in the
+;;; reported total CPU time. The sum of total CPU time and the estimated
+;;; monitoring overhead should be close to the total CPU time for the
+;;; entire monitoring run (as determined by TIME).
+;;;
+;;; A timing overhead factor is computed at load time. This will be incorrect
+;;; if the monitoring code is run in a different environment than this file
+;;; was loaded in. For example, saving a core image on a high performance
+;;; machine and running it on a low performance one will result in the use
+;;; of an erroneously small overhead factor.
+;;;
+;;;
+;;; If your times vary widely, possible causes are:
+;;; - Garbage collection. Try turning it off, then running your code.
+;;; Be warned that monitoring code will probably cons when it does
+;;; (get-internal-run-time).
+;;; - Swapping. If you have enough memory, execute your form once
+;;; before monitoring so that it will be swapped into memory. Otherwise,
+;;; get a bigger machine!
+;;; - Resolution of internal-time-units-per-second. If this value is
+;;; too low, then the timings become wild. You can try executing more
+;;; of whatever your test is, but that will only work if some of your
+;;; paths do not match the timer resolution.
+;;; internal-time-units-per-second is so coarse -- on a Symbolics it is
+;;; 977, in MACL it is 60.
+;;;
+;;;
+
+;;; ****************************************************************
+;;; Interface ******************************************************
+;;; ****************************************************************
+;;;
+;;; WITH-MONITORING (&rest functions) [Macro]
+;;; (&optional (nested :exclusive)
+;;; (threshold 0.01)
+;;; (key :percent-time))
+;;; &body body
+;;; The named functions will be set up for monitoring, the body forms executed,
+;;; a table of results printed, and the functions unmonitored. The nested,
+;;; threshold, and key arguments are passed to report-monitoring below.
+;;;
+;;; MONITOR-FORM form [Macro]
+;;; &optional (nested :exclusive)
+;;; (threshold 0.01)
+;;; (key :percent-time)
+;;; All functions in the current package are set up for monitoring while
+;;; the form is executed, and automatically unmonitored after a table of
+;;; results has been printed. The nested, threshold, and key arguments
+;;; are passed to report-monitoring below.
+;;;
+;;; *MONITORED-FUNCTIONS* [Variable]
+;;; This holds a list of all functions that are currently being monitored.
+;;;
+;;; MONITOR &rest names [Macro]
+;;; The named functions will be set up for monitoring by augmenting
+;;; their function definitions with code that gathers statistical information
+;;; about code performance. As with the TRACE macro, the function names are
+;;; not evaluated. Calls the function MON::MONITORING-ENCAPSULATE on each
+;;; function name. If no names are specified, returns a list of all
+;;; monitored functions.
+;;;
+;;; If name is not a symbol, it is evaled to return the appropriate
+;;; closure. This allows you to monitor closures stored anywhere like
+;;; in a variable, array or structure. Most other monitoring packages
+;;; can't handle this.
+;;;
+;;; MONITOR-ALL &optional (package *package*) [Function]
+;;; Monitors all functions in the specified package, which defaults to
+;;; the current package.
+;;;
+;;; UNMONITOR &rest names [Macro]
+;;; Removes monitoring code from the named functions. If no names are
+;;; specified, all currently monitored functions are unmonitored.
+;;;
+;;; RESET-MONITORING-INFO name [Function]
+;;; Resets the monitoring statistics for the specified function.
+;;;
+;;; RESET-ALL-MONITORING [Function]
+;;; Resets the monitoring statistics for all monitored functions.
+;;;
+;;; MONITORED name [Function]
+;;; Predicate to test whether a function is monitored.
+;;;
+;;; REPORT-MONITORING &optional names [Function]
+;;; (nested :exclusive)
+;;; (threshold 0.01)
+;;; (key :percent-time)
+;;; Creates a table of monitoring information for the specified list
+;;; of names, and displays the table using display-monitoring-results.
+;;; If names is :all or nil, uses all currently monitored functions.
+;;; Takes the following arguments:
+;;; - NESTED specifies whether nested calls of monitored functions
+;;; are included in the times for monitored functions.
+;;; o If :inclusive, the per-function information is for the entire
+;;; duration of the monitored function, including any calls to
+;;; other monitored functions. If functions A and B are monitored,
+;;; and A calls B, then the accumulated time and consing for A will
+;;; include the time and consing of B. Note: if a function calls
+;;; itself recursively, the time spent in the inner call(s) may
+;;; be counted several times.
+;;; o If :exclusive, the information excludes time attributed to
+;;; calls to other monitored functions. This is the default.
+;;; - THRESHOLD specifies that only functions which have been executed
+;;; more than threshold percent of the time will be reported. Defaults
+;;; to 1%. If a threshold of 0 is specified, all functions are listed,
+;;; even those with 0 or negative running times (see note on overhead).
+;;; - KEY specifies that the table be sorted by one of the following
+;;; sort keys:
+;;; :function alphabetically by function name
+;;; :percent-time by percent of total execution time
+;;; :percent-cons by percent of total consing
+;;; :calls by number of times the function was called
+;;; :time-per-call by average execution time per function
+;;; :cons-per-call by average consing per function
+;;; :time same as :percent-time
+;;; :cons same as :percent-cons
+;;;
+;;; REPORT &key (names :all) [Function]
+;;; (nested :exclusive)
+;;; (threshold 0.01)
+;;; (sort-key :percent-time)
+;;; (ignore-no-calls nil)
+;;;
+;;; Same as REPORT-MONITORING but we use a nicer keyword interface.
+;;;
+;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function]
+;;; (key :percent-time)
+;;; Prints a table showing for each named function:
+;;; - the total CPU time used in that function for all calls
+;;; - the total number of bytes consed in that function for all calls
+;;; - the total number of calls
+;;; - the average amount of CPU time per call
+;;; - the average amount of consing per call
+;;; - the percent of total execution time spent executing that function
+;;; - the percent of total consing spent consing in that function
+;;; Summary totals of the CPU time, consing, and calls columns are printed.
+;;; An estimate of the monitoring overhead is also printed. May be run
+;;; even after unmonitoring all the functions, to play with the data.
+;;;
+;;; SAMPLE TABLE:
+#|
+ Cons
+ % % Per Total Total
+Function Time Cons Calls Sec/Call Call Time Cons
+----------------------------------------------------------------------
+FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0
+GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0
+GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0
+FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0
+----------------------------------------------------------------------
+TOTAL: 1173 0.828950 0
+Estimated total monitoring overhead: 0.88 seconds
+|#
+
+;;; ****************************************************************
+;;; METERING *******************************************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Warn people using the wrong Lisp
+;;; ********************************
+
+#-(or clisp openmcl)
+(warn "metering.lisp does not support your Lisp implementation!")
+
+;;; ********************************
+;;; Packages ***********************
+;;; ********************************
+
+;;; For CLtL2 compatible lisps
+
+(defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP")
+ (:export "*MONITORED-FUNCTIONS*"
+ "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM"
+ "WITH-MONITORING"
+ "RESET-MONITORING-INFO" "RESET-ALL-MONITORING"
+ "MONITORED"
+ "REPORT-MONITORING"
+ "DISPLAY-MONITORING-RESULTS"
+ "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE"
+ "REPORT"))
+(in-package "MONITOR")
+
+;;; Warn user if they're loading the source instead of compiling it first.
+(eval-when (eval)
+ (warn "This file should be compiled before loading for best results."))
+
+;;; ********************************
+;;; Version ************************
+;;; ********************************
+
+(defparameter *metering-version* "v2.1 25-JAN-94"
+ "Current version number/date for Metering.")
+
+
+;;; ****************************************************************
+;;; Implementation Dependent Definitions ***************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Timing Functions ***************
+;;; ********************************
+;;; The get-time function is called to find the total number of ticks since
+;;; the beginning of time. time-units-per-second allows us to convert units
+;;; to seconds.
+
+#-(or clisp openmcl)
+(eval-when (compile eval)
+ (warn
+ "You may want to supply implementation-specific get-time functions."))
+
+(defconstant time-units-per-second internal-time-units-per-second)
+
+(defmacro get-time ()
+ `(the time-type (get-internal-run-time)))
+
+;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of
+;;; milliseconds spent during GC. We could subtract this from
+;;; the value returned by get-internal-run-time to eliminate
+;;; the effect of GC on the timing values, but we prefer to let
+;;; the user run without GC on. If the application is so big that
+;;; it requires GC to complete, then the GC times are part of the
+;;; cost of doing business, and will average out in the long run.
+;;; If it seems really important to a user that GC times not be
+;;; counted, then uncomment the following three lines and read-time
+;;; conditionalize the definition of get-time above with #-:openmcl.
+;#+openmcl
+;(defmacro get-time ()
+; `(the time-type (- (get-internal-run-time) (ccl:gctime))))
+
+;;; ********************************
+;;; Consing Functions **************
+;;; ********************************
+;;; The get-cons macro is called to find the total number of bytes
+;;; consed since the beginning of time.
+
+#+clisp
+(defun get-cons ()
+ (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
+ (sys::%%time)
+ (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
+ (dpb space1 (byte 24 24) space2)))
+
+;;; Macintosh Common Lisp 2.0
+;;; Note that this includes bytes that were allocated during GC.
+;;; We could subtract this out by advising GC like we did under
+;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't
+;;; run without GC, then the bytes consed during GC are a cost of
+;;; running their program. Metering the code a few times will
+;;; avoid the consing values being too lopsided. If a user really really
+;;; wants to subtract out the consing during GC, replace the following
+;;; two lines with the commented out code.
+#+openmcl
+(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
+;; #+openmcl
+;; (progn
+;; (in-package :ccl)
+;; (defvar *bytes-consed-chkpt* 0)
+;; (defun reset-consing () (setq *bytes-consed-chkpt* 0))
+;; (let ((old-gc (symbol-function 'gc))
+;; (ccl:*warn-if-redefine-kernel* nil))
+;; (setf (symbol-function 'gc)
+;; #'(lambda ()
+;; (let ((old-consing (total-bytes-consed)))
+;; (prog1
+;; (funcall old-gc)
+;; (incf *bytes-consed-chkpt*
+;; (- old-consing (total-bytes-consed))))))))
+;; (defun total-bytes-consed ()
+;; "Returns number of conses (8 bytes each)"
+;; (ccl::total-bytes-allocated))
+;; (in-package "MONITOR")
+;; (defun get-cons ()
+;; (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*))))
+
+
+#-(or clisp openmcl)
+(progn
+ (eval-when (compile eval)
+ (warn "No consing will be reported unless a get-cons function is ~
+ defined."))
+
+ (defmacro get-cons () '(the consing-type 0)))
+
+;; actually, neither `get-cons' nor `get-time' are used as is,
+;; but only in the following macro `with-time/cons'
+#-:clisp
+(defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
+ (let ((start-cons (gensym "START-CONS-"))
+ (start-time (gensym "START-TIME-")))
+ `(let ((,start-time (get-time)) (,start-cons (get-cons)))
+ (declare (type time-type ,start-time)
+ (type consing-type ,start-cons))
+ (multiple-value-prog1 ,form
+ (let ((,delta-time (- (get-time) ,start-time))
+ (,delta-cons (- (get-cons) ,start-cons)))
+ ,@post-process)))))
+
+#+clisp
+(progn
+ (defmacro delta4 (nv1 nv2 ov1 ov2 by)
+ `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2))
+
+ (let ((del (find-symbol "DELTA4" "SYS")))
+ (when del (setf (fdefinition 'delta4) (fdefinition del))))
+
+ (if (< internal-time-units-per-second 1000000)
+ ;; TIME_1: AMIGA, OS/2, UNIX_TIMES
+ (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
+ `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16))
+ ;; TIME_2: other UNIX, WIN32
+ (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
+ `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second)
+ (- ,new-time2 ,old-time2))))
+
+ (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2)
+ `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24))
+
+ ;; avoid consing: when the application conses a lot,
+ ;; get-cons may return a bignum, so we really should not use it.
+ (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
+ (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-"))
+ (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-"))
+ (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-"))
+ (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
+ (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
+ `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
+ ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time)
+ (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
+ (multiple-value-prog1 ,form
+ (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
+ ,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time)
+ (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
+ (let ((,delta-time (delta4-time ,end-time1 ,end-time2
+ ,beg-time1 ,beg-time2))
+ (,delta-cons (delta4-cons ,end-cons1 ,end-cons2
+ ,beg-cons1 ,beg-cons2)))
+ ,@post-process)))))))
+
+;;; ********************************
+;;; Required Arguments *************
+;;; ********************************
+;;;
+;;; Required (Fixed) vs Optional Args
+;;;
+;;; To avoid unnecessary consing in the "encapsulation" code, we find out the
+;;; number of required arguments, and use &rest to capture only non-required
+;;; arguments. The function Required-Arguments returns two values: the first
+;;; is the number of required arguments, and the second is T iff there are any
+;;; non-required arguments (e.g. &optional, &rest, &key).
+
+;;; Lucid, Allegro, and Macintosh Common Lisp
+#+openmcl
+(defun required-arguments (name)
+ (let* ((function (symbol-function name))
+ (args (ccl:arglist function))
+ (pos (position-if #'(lambda (x)
+ (and (symbolp x)
+ (let ((name (symbol-name x)))
+ (and (>= (length name) 1)
+ (char= (schar name 0)
+ #\&)))))
+ args)))
+ (if pos
+ (values pos t)
+ (values (length args) nil))))
+
+#+clisp
+(defun required-arguments (name)
+ (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p)
+ (sys::function-signature name t)
+ (if name ; no error
+ (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))
+ (values 0 t))))
+
+#-(or clisp openmcl)
+(progn
+ (eval-when (compile eval)
+ (warn
+ "You may want to add an implementation-specific Required-Arguments function."))
+ (eval-when (load eval)
+ (defun required-arguments (name)
+ (declare (ignore name))
+ (values 0 t))))
+
+#|
+;;;Examples
+(defun square (x) (* x x))
+(defun square2 (x &optional y) (* x x y))
+(defun test (x y &optional (z 3)) 3)
+(defun test2 (x y &optional (z 3) &rest fred) 3)
+
+(required-arguments 'square) => 1 nil
+(required-arguments 'square2) => 1 t
+(required-arguments 'test) => 2 t
+(required-arguments 'test2) => 2 t
+|#
+
+
+;;; ****************************************************************
+;;; Main METERING Code *********************************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Global Variables ***************
+;;; ********************************
+(defvar *MONITOR-TIME-OVERHEAD* nil
+ "The amount of time an empty monitored function costs.")
+(defvar *MONITOR-CONS-OVERHEAD* nil
+ "The amount of cons an empty monitored function costs.")
+
+(defvar *TOTAL-TIME* 0
+ "Total amount of time monitored so far.")
+(defvar *TOTAL-CONS* 0
+ "Total amount of consing monitored so far.")
+(defvar *TOTAL-CALLS* 0
+ "Total number of calls monitored so far.")
+(proclaim '(type time-type *total-time*))
+(proclaim '(type consing-type *total-cons*))
+(proclaim '(fixnum *total-calls*))
+
+;;; ********************************
+;;; Accessor Functions *************
+;;; ********************************
+;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables
+;;; containing closures.
+(defmacro PLACE-FUNCTION (function-place)
+ "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
+if it isn't a symbol, to allow monitoring of closures located in
+variables/arrays/structures."
+ ;; Note that (fboundp 'fdefinition) returns T even if fdefinition
+ ;; is a macro, which is what we want.
+ (if (fboundp 'fdefinition)
+ `(if (fboundp ,function-place)
+ (fdefinition ,function-place)
+ (eval ,function-place))
+ `(if (symbolp ,function-place)
+ (symbol-function ,function-place)
+ (eval ,function-place))))
+
+(defsetf PLACE-FUNCTION (function-place) (function)
+ "Set the function in FUNCTION-PLACE to FUNCTION."
+ (if (fboundp 'fdefinition)
+ ;; If we're conforming to CLtL2, use fdefinition here.
+ `(if (fboundp ,function-place)
+ (setf (fdefinition ,function-place) ,function)
+ (eval '(setf ,function-place ',function)))
+ `(if (symbolp ,function-place)
+ (setf (symbol-function ,function-place) ,function)
+ (eval '(setf ,function-place ',function)))))
+
+#|
+;;; before using fdefinition
+(defun PLACE-FUNCTION (function-place)
+ "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE
+if it isn't a symbol, to allow monitoring of closures located in
+variables/arrays/structures."
+ (if (symbolp function-place)
+ (symbol-function function-place)
+ (eval function-place)))
+
+(defsetf PLACE-FUNCTION (function-place) (function)
+ "Set the function in FUNCTION-PLACE to FUNCTION."
+ `(if (symbolp ,function-place)
+ (setf (symbol-function ,function-place) ,function)
+ (eval '(setf ,function-place ',function))))
+|#
+
+(defun PLACE-FBOUNDP (function-place)
+ "Test to see if FUNCTION-PLACE is a function."
+ ;; probably should be
+ #|(or (and (symbolp function-place)(fboundp function-place))
+ (functionp (place-function function-place)))|#
+ (if (symbolp function-place)
+ (fboundp function-place)
+ (functionp (place-function function-place))))
+
+(defun PLACE-MACROP (function-place)
+ "Test to see if FUNCTION-PLACE is a macro."
+ (when (symbolp function-place)
+ (macro-function function-place)))
+
+;;; ********************************
+;;; Measurement Tables *************
+;;; ********************************
+(defvar *monitored-functions* nil
+ "List of monitored symbols.")
+
+;;; We associate a METERING-FUNCTIONS structure with each monitored function
+;;; name or other closure. This holds the functions that we call to manipulate
+;;; the closure which implements the encapsulation.
+;;;
+(defstruct metering-functions
+ (name nil)
+ (old-definition nil :type function)
+ (new-definition nil :type function)
+ (read-metering nil :type function)
+ (reset-metering nil :type function))
+
+;;; In general using hash tables in time-critical programs is a bad idea,
+;;; because when one has to grow the table and rehash everything, the
+;;; timing becomes grossly inaccurate. In this case it is not an issue
+;;; because all inserting of entries in the hash table occurs before the
+;;; timing commences. The only circumstance in which this could be a
+;;; problem is if the lisp rehashes on the next reference to the table,
+;;; instead of when the entry which forces a rehash was inserted.
+;;;
+;;; Note that a similar kind of problem can occur with GC, which is why
+;;; one should turn off GC when monitoring code.
+;;;
+(defvar *monitor* (make-hash-table :test #'equal)
+ "Hash table in which METERING-FUNCTIONS structures are stored.")
+(defun get-monitor-info (name)
+ (gethash name *monitor*))
+(defsetf get-monitor-info (name) (info)
+ `(setf (gethash ,name *monitor*) ,info))
+
+(defun MONITORED (function-place)
+ "Test to see if a FUNCTION-PLACE is monitored."
+ (and (place-fboundp function-place) ; this line necessary?
+ (get-monitor-info function-place)))
+
+(defun reset-monitoring-info (name)
+ "Reset the monitoring info for the specified function."
+ (let ((finfo (get-monitor-info name)))
+ (when finfo
+ (funcall (metering-functions-reset-metering finfo)))))
+(defun reset-all-monitoring ()
+ "Reset monitoring info for all functions."
+ (setq *total-time* 0
+ *total-cons* 0
+ *total-calls* 0)
+ (dolist (symbol *monitored-functions*)
+ (when (monitored symbol)
+ (reset-monitoring-info symbol))))
+
+(defun monitor-info-values (name &optional (nested :exclusive) warn)
+ "Returns monitoring information values for the named function,
+adjusted for overhead."
+ (let ((finfo (get-monitor-info name)))
+ (if finfo
+ (multiple-value-bind (inclusive-time inclusive-cons
+ exclusive-time exclusive-cons
+ calls nested-calls)
+ (funcall (metering-functions-read-metering finfo))
+ (unless (or (null warn)
+ (eq (place-function name)
+ (metering-functions-new-definition finfo)))
+ (warn "Funtion ~S has been redefined, so times may be inaccurate.~@
+ MONITOR it again to record calls to the new definition."
+ name))
+ (case nested
+ (:exclusive (values calls
+ nested-calls
+ (- exclusive-time
+ (* calls *monitor-time-overhead*))
+ (- exclusive-cons
+ (* calls *monitor-cons-overhead*))))
+ ;; In :inclusive mode, subtract overhead for all the
+ ;; called functions as well. Nested-calls includes the
+ ;; calls of the function as well. [Necessary 'cause of
+ ;; functions which call themselves recursively.]
+ (:inclusive (values calls
+ nested-calls
+ (- inclusive-time
+ (* nested-calls ;(+ calls)
+ *monitor-time-overhead*))
+ (- inclusive-cons
+ (* nested-calls ;(+ calls)
+ *monitor-cons-overhead*))))))
+ (values 0 0 0 0))))
+
+;;; ********************************
+;;; Encapsulate ********************
+;;; ********************************
+(eval-when (compile load eval)
+;; Returns a lambda expression for a function that, when called with the
+;; function name, will set up that function for metering.
+;;
+;; A function is monitored by replacing its definition with a closure
+;; created by the following function. The closure records the monitoring
+;; data, and updates the data with each call of the function.
+;;
+;; Other closures are used to read and reset the data.
+(defun make-monitoring-encapsulation (min-args optionals-p)
+ (let (required-args)
+ (dotimes (i min-args) (push (gensym) required-args))
+ `(lambda (name)
+ (let ((inclusive-time 0)
+ (inclusive-cons 0)
+ (exclusive-time 0)
+ (exclusive-cons 0)
+ (calls 0)
+ (nested-calls 0)
+ (old-definition (place-function name)))
+ (declare (type time-type inclusive-time)
+ (type time-type exclusive-time)
+ (type consing-type inclusive-cons)
+ (type consing-type exclusive-cons)
+ (fixnum calls)
+ (fixnum nested-calls))
+ (pushnew name *monitored-functions*)
+
+ (setf (place-function name)
+ #'(lambda (,@required-args
+ ,@(when optionals-p
+ `(&rest optional-args)))
+ (let ((prev-total-time *total-time*)
+ (prev-total-cons *total-cons*)
+ (prev-total-calls *total-calls*)
+ ;; (old-time inclusive-time)
+ ;; (old-cons inclusive-cons)
+ ;; (old-nested-calls nested-calls)
+ )
+ (declare (type time-type prev-total-time)
+ (type consing-type prev-total-cons)
+ (fixnum prev-total-calls))
+ (with-time/cons (delta-time delta-cons)
+ ;; form
+ ,(if optionals-p
+ `(apply old-definition
+ ,@required-args optional-args)
+ `(funcall old-definition ,@required-args))
+ ;; post-processing:
+ ;; Calls
+ (incf calls)
+ (incf *total-calls*)
+ ;; nested-calls includes this call
+ (incf nested-calls (the fixnum
+ (- *total-calls*
+ prev-total-calls)))
+ ;; (setf nested-calls (+ old-nested-calls
+ ;; (- *total-calls*
+ ;; prev-total-calls)))
+ ;; Time
+ ;; Problem with inclusive time is that it
+ ;; currently doesn't add values from recursive
+ ;; calls to the same function. Change the
+ ;; setf to an incf to fix this?
+ (incf inclusive-time (the time-type delta-time))
+ ;; (setf inclusive-time (+ delta-time old-time))
+ (incf exclusive-time (the time-type
+ (+ delta-time
+ (- prev-total-time
+ *total-time*))))
+ (setf *total-time* (the time-type
+ (+ delta-time
+ prev-total-time)))
+ ;; Consing
+ (incf inclusive-cons (the consing-type delta-cons))
+ ;; (setf inclusive-cons (+ delta-cons old-cons))
+ (incf exclusive-cons (the consing-type
+ (+ delta-cons
+ (- prev-total-cons
+ *total-cons*))))
+ (setf *total-cons*
+ (the consing-type
+ (+ delta-cons prev-total-cons)))))))
+ (setf (get-monitor-info name)
+ (make-metering-functions
+ :name name
+ :old-definition old-definition
+ :new-definition (place-function name)
+ :read-metering #'(lambda ()
+ (values inclusive-time
+ inclusive-cons
+ exclusive-time
+ exclusive-cons
+ calls
+ nested-calls))
+ :reset-metering #'(lambda ()
+ (setq inclusive-time 0
+ inclusive-cons 0
+ exclusive-time 0
+ exclusive-cons 0
+ calls 0
+ nested-calls 0)
+ t)))))))
+);; End of EVAL-WHEN
+
+;;; For efficiency reasons, we precompute the encapsulation functions
+;;; for a variety of combinations of argument structures
+;;; (min-args . optional-p). These are stored in the following hash table
+;;; along with any new ones we encounter. Since we're now precomputing
+;;; closure functions for common argument signatures, this eliminates
+;;; the former need to call COMPILE for each monitored function.
+(eval-when (compile eval)
+ (defconstant precomputed-encapsulations 8))
+
+(defvar *existing-encapsulations* (make-hash-table :test #'equal))
+(defun find-encapsulation (min-args optionals-p)
+ (or (gethash (cons min-args optionals-p) *existing-encapsulations*)
+ (setf (gethash (cons min-args optionals-p) *existing-encapsulations*)
+ (compile nil
+ (make-monitoring-encapsulation min-args optionals-p)))))
+
+(macrolet ((frob ()
+ (let ((res ()))
+ (dotimes (i precomputed-encapsulations)
+ (push `(setf (gethash '(,i . nil) *existing-encapsulations*)
+ #',(make-monitoring-encapsulation i nil))
+ res)
+ (push `(setf (gethash '(,i . t) *existing-encapsulations*)
+ #',(make-monitoring-encapsulation i t))
+ res))
+ `(progn ,@res))))
+ (frob))
+
+(defun monitoring-encapsulate (name &optional warn)
+ "Monitor the function Name. If already monitored, unmonitor first."
+ ;; Saves the current definition of name and inserts a new function which
+ ;; returns the result of evaluating body.
+ (cond ((not (place-fboundp name)) ; not a function
+ (when warn
+ (warn "Ignoring undefined function ~S." name)))
+ ((place-macrop name) ; a macro
+ (when warn
+ (warn "Ignoring macro ~S." name)))
+ (t ; tis a function
+ (when (get-monitor-info name) ; monitored
+ (when warn
+ (warn "~S already monitored, so unmonitoring it first." name))
+ (monitoring-unencapsulate name))
+ (multiple-value-bind (min-args optionals-p)
+ (required-arguments name)
+ (funcall (find-encapsulation min-args optionals-p) name)))))
+
+(defun monitoring-unencapsulate (name &optional warn)
+ "Removes monitoring encapsulation code from around Name."
+ (let ((finfo (get-monitor-info name)))
+ (when finfo ; monitored
+ (remprop name 'metering-functions)
+ (setq *monitored-functions*
+ (remove name *monitored-functions* :test #'equal))
+ (if (eq (place-function name)
+ (metering-functions-new-definition finfo))
+ (setf (place-function name)
+ (metering-functions-old-definition finfo))
+ (when warn
+ (warn "Preserving current definition of redefined function ~S."
+ name))))))
+
+;;; ********************************
+;;; Main Monitoring Functions ******
+;;; ********************************
+(defmacro MONITOR (&rest names)
+ "Monitor the named functions. As in TRACE, the names are not evaluated.
+ If a function is already monitored, then unmonitor and remonitor (useful
+ to notice function redefinition). If a name is undefined, give a warning
+ and ignore it. See also unmonitor, report-monitoring,
+ display-monitoring-results and reset-time."
+ `(progn
+ ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names)
+ *monitored-functions*))
+
+(defmacro UNMONITOR (&rest names)
+ "Remove the monitoring on the named functions.
+ Names defaults to the list of all currently monitored functions."
+ `(dolist (name ,(if names `',names '*monitored-functions*) (values))
+ (monitoring-unencapsulate name)))
+
+(defun MONITOR-ALL (&optional (package *package*))
+ "Monitor all functions in the specified package."
+ (let ((package (if (packagep package)
+ package
+ (find-package package))))
+ (do-symbols (symbol package)
+ (when (eq (symbol-package symbol) package)
+ (monitoring-encapsulate symbol)))))
+
+(defmacro MONITOR-FORM (form
+ &optional (nested :exclusive) (threshold 0.01)
+ (key :percent-time))
+ "Monitor the execution of all functions in the current package
+during the execution of FORM. All functions that are executed above
+THRESHOLD % will be reported."
+ `(unwind-protect
+ (progn
+ (monitor-all)
+ (reset-all-monitoring)
+ (prog1
+ (time ,form)
+ (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls)))
+ (unmonitor)))
+
+(defmacro WITH-MONITORING ((&rest functions)
+ (&optional (nested :exclusive)
+ (threshold 0.01)
+ (key :percent-time))
+ &body body)
+ "Monitor the specified functions during the execution of the body."
+ `(unwind-protect
+ (progn
+ (dolist (fun ',functions)
+ (monitoring-encapsulate fun))
+ (reset-all-monitoring)
+ ,@body
+ (report-monitoring :all ,nested ,threshold ,key))
+ (unmonitor)))
+
+;;; ********************************
+;;; Overhead Calculations **********
+;;; ********************************
+(defconstant overhead-iterations 5000
+ "Number of iterations over which the timing overhead is averaged.")
+
+;;; Perhaps this should return something to frustrate clever compilers.
+(defun STUB-FUNCTION (x)
+ (declare (ignore x))
+ nil)
+(proclaim '(notinline stub-function))
+
+(defun SET-MONITOR-OVERHEAD ()
+ "Determines the average overhead of monitoring by monitoring the execution
+of an empty function many times."
+ (setq *monitor-time-overhead* 0
+ *monitor-cons-overhead* 0)
+ (stub-function nil)
+ (monitor stub-function)
+ (reset-all-monitoring)
+ (let ((overhead-function (symbol-function 'stub-function)))
+ (dotimes (x overhead-iterations)
+ (funcall overhead-function overhead-function)))
+; (dotimes (x overhead-iterations)
+; (stub-function nil))
+ (let ((fiter (float overhead-iterations)))
+ (multiple-value-bind (calls nested-calls time cons)
+ (monitor-info-values 'stub-function)
+ (declare (ignore calls nested-calls))
+ (setq *monitor-time-overhead* (/ time fiter)
+ *monitor-cons-overhead* (/ cons fiter))))
+ (unmonitor stub-function))
+(set-monitor-overhead)
+
+;;; ********************************
+;;; Report Data ********************
+;;; ********************************
+(defvar *monitor-results* nil
+ "A table of monitoring statistics is stored here.")
+(defvar *no-calls* nil
+ "A list of monitored functions which weren't called.")
+(defvar *estimated-total-overhead* 0)
+;; (proclaim '(type time-type *estimated-total-overhead*))
+
+(defstruct (monitoring-info
+ (:conc-name m-info-)
+ (:constructor make-monitoring-info
+ (name calls time cons
+ percent-time percent-cons
+ time-per-call cons-per-call)))
+ name
+ calls
+ time
+ cons
+ percent-time
+ percent-cons
+ time-per-call
+ cons-per-call)
+
+(defun REPORT (&key (names :all)
+ (nested :exclusive)
+ (threshold 0.01)
+ (sort-key :percent-time)
+ (ignore-no-calls nil))
+ "Same as REPORT-MONITORING but with a nicer keyword interface"
+ (declare (type (member :function :percent-time :time :percent-cons
+ :cons :calls :time-per-call :cons-per-call)
+ sort-key)
+ (type (member :inclusive :exclusive) nested))
+ (report-monitoring names nested threshold sort-key ignore-no-calls))
+
+(defun REPORT-MONITORING (&optional names
+ (nested :exclusive)
+ (threshold 0.01)
+ (key :percent-time)
+ ignore-no-calls)
+ "Report the current monitoring state.
+The percentage of the total time spent executing unmonitored code
+in each function (:exclusive mode), or total time (:inclusive mode)
+will be printed together with the number of calls and
+the unmonitored time per call. Functions that have been executed
+below THRESHOLD % of the time will not be reported. To report on all
+functions set NAMES to be either NIL or :ALL."
+ (when (or (null names) (eq names :all)) (setq names *monitored-functions*))
+
+ (let ((total-time 0)
+ (total-cons 0)
+ (total-calls 0))
+ ;; Compute overall time and consing.
+ (dolist (name names)
+ (multiple-value-bind (calls nested-calls time cons)
+ (monitor-info-values name nested :warn)
+ (declare (ignore nested-calls))
+ (incf total-calls calls)
+ (incf total-time time)
+ (incf total-cons cons)))
+ ;; Total overhead.
+ (setq *estimated-total-overhead*
+ (/ (* *monitor-time-overhead* total-calls)
+ time-units-per-second))
+ ;; Assemble data for only the specified names (all monitored functions)
+ (if (zerop total-time)
+ (format *trace-output* "Not enough execution time to monitor.")
+ (progn
+ (setq *monitor-results* nil *no-calls* nil)
+ (dolist (name names)
+ (multiple-value-bind (calls nested-calls time cons)
+ (monitor-info-values name nested)
+ (declare (ignore nested-calls))
+ (when (minusp time) (setq time 0.0))
+ (when (minusp cons) (setq cons 0.0))
+ (if (zerop calls)
+ (push (if (symbolp name)
+ (symbol-name name)
+ (format nil "~S" name))
+ *no-calls*)
+ (push (make-monitoring-info
+ (format nil "~S" name) ; name
+ calls ; calls
+ (/ time (float time-units-per-second)) ; time in secs
+ (round cons) ; consing
+ (/ time (float total-time)) ; percent-time
+ (if (zerop total-cons) 0
+ (/ cons (float total-cons))) ; percent-cons
+ (/ (/ time (float calls)) ; time-per-call
+ time-units-per-second) ; sec/call
+ (round (/ cons (float calls)))) ; cons-per-call
+ *monitor-results*))))
+ (display-monitoring-results threshold key ignore-no-calls)))))
+
+(defun display-monitoring-results (&optional (threshold 0.01) (key :percent-time)
+ (ignore-no-calls t))
+ (let ((max-length 8) ; Function header size
+ (max-cons-length 8)
+ (total-time 0.0)
+ (total-consed 0)
+ (total-calls 0)
+ (total-percent-time 0)
+ (total-percent-cons 0))
+ (sort-results key)
+ (dolist (result *monitor-results*)
+ (when (or (zerop threshold)
+ (> (m-info-percent-time result) threshold))
+ (setq max-length
+ (max max-length
+ (length (m-info-name result))))
+ (setq max-cons-length
+ (max max-cons-length
+ (m-info-cons-per-call result)))))
+ (incf max-length 2)
+ (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10))))
+ (format *trace-output*
+ "~%~%~
+ ~VT ~VA~
+ ~% ~VT % % ~VA Total Total~
+ ~%Function~VT Time Cons Calls Sec/Call ~VA Time Cons~
+ ~%~V,,,'-A"
+ max-length
+ max-cons-length "Cons"
+ max-length
+ max-cons-length "Per"
+ max-length
+ max-cons-length "Call"
+ (+ max-length 62 (max 0 (- max-cons-length 5))) "-")
+ (dolist (result *monitor-results*)
+ (when (or (zerop threshold)
+ (> (m-info-percent-time result) threshold))
+ (format *trace-output*
+ "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D"
+ (m-info-name result)
+ max-length
+ (* 100 (m-info-percent-time result))
+ (* 100 (m-info-percent-cons result))
+ (m-info-calls result)
+ (m-info-time-per-call result)
+ max-cons-length
+ (m-info-cons-per-call result)
+ (m-info-time result)
+ (m-info-cons result))
+ (incf total-time (m-info-time result))
+ (incf total-consed (m-info-cons result))
+ (incf total-calls (m-info-calls result))
+ (incf total-percent-time (m-info-percent-time result))
+ (incf total-percent-cons (m-info-percent-cons result))))
+ (format *trace-output*
+ "~%~V,,,'-A~
+ ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~
+ ~%Estimated monitoring overhead: ~5,2F seconds~
+ ~%Estimated total monitoring overhead: ~5,2F seconds"
+ (+ max-length 62 (max 0 (- max-cons-length 5))) "-"
+ max-length
+ (* 100 total-percent-time)
+ (* 100 total-percent-cons)
+ total-calls
+ max-cons-length " "
+ total-time total-consed
+ (/ (* *monitor-time-overhead* total-calls)
+ time-units-per-second)
+ *estimated-total-overhead*)
+ (when (and (not ignore-no-calls) *no-calls*)
+ (setq *no-calls* (sort *no-calls* #'string<))
+ (let ((num-no-calls (length *no-calls*)))
+ (if (> num-no-calls 20)
+ (format *trace-output*
+ "~%~@(~r~) monitored functions were not called. ~
+ ~%See the variable mon::*no-calls* for a list."
+ num-no-calls)
+ (format *trace-output*
+ "~%The following monitored functions were not called:~
+ ~%~{~<~%~:; ~A~>~}~%"
+ *no-calls*))))
+ (values)))
+
+(defun sort-results (&optional (key :percent-time))
+ (setq *monitor-results*
+ (case key
+ (:function (sort *monitor-results* #'string>
+ :key #'m-info-name))
+ ((:percent-time :time) (sort *monitor-results* #'>
+ :key #'m-info-time))
+ ((:percent-cons :cons) (sort *monitor-results* #'>
+ :key #'m-info-cons))
+ (:calls (sort *monitor-results* #'>
+ :key #'m-info-calls))
+ (:time-per-call (sort *monitor-results* #'>
+ :key #'m-info-time-per-call))
+ (:cons-per-call (sort *monitor-results* #'>
+ :key #'m-info-cons-per-call)))))
+
+;;; *END OF FILE*
+
+
Added: branches/bos/thirdparty/emacs/slime/mkdist.sh
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/mkdist.sh Fri Jan 18 06:05:59 2008
@@ -0,0 +1,17 @@
+#!/bin/sh
+
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
+version="1.2"
+dist="slime-$version"
+
+if [ -d $dist ]; then rm -rf $dist; fi
+
+mkdir $dist
+cp NEWS README HACKING PROBLEMS ChangeLog *.el *.lisp $dist/
+
+mkdir $dist/doc
+cp doc/Makefile doc/slime.texi doc/texinfo-tabulate.awk $dist/doc
+
+tar czf $dist.tar.gz $dist
Added: branches/bos/thirdparty/emacs/slime/nregex.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/nregex.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,523 @@
+;;;
+;;; This code was written by:
+;;;
+;;; Lawrence E. Freil <lef(a)freil.com>
+;;; National Science Center Foundation
+;;; Augusta, Georgia 30909
+;;;
+;;; This program was released into the public domain on 2005-08-31.
+;;; (See the slime-devel mailing list archive for details.)
+;;;
+;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression
+;;; parser.
+;;;
+;;; This regular expression parser operates by taking a
+;;; regular expression and breaking it down into a list
+;;; consisting of lisp expressions and flags. The list
+;;; of lisp expressions is then taken in turned into a
+;;; lambda expression that can be later applied to a
+;;; string argument for parsing.
+;;;;
+;;;; Modifications made 6 March 2001 By Chris Double (chris(a)double.co.nz)
+;;;; to get working with Corman Lisp 1.42, add package statement and export
+;;;; relevant functions.
+;;;;
+
+(in-package :cl-user)
+
+;; Renamed to slime-nregex avoid name clashes with other versions of
+;; this file. -- he
+
+;;;; CND - 6/3/2001
+(defpackage slime-nregex
+ (:use #:common-lisp)
+ (:export
+ #:regex
+ #:regex-compile
+ ))
+
+;;;; CND - 6/3/2001
+(in-package :slime-nregex)
+
+;;;
+;;; First we create a copy of macros to help debug the beast
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defvar *regex-debug* nil) ; Set to nil for no debugging code
+)
+
+(defmacro info (message &rest args)
+ (if *regex-debug*
+ `(format *standard-output* ,message ,@args)))
+
+;;;
+;;; Declare the global variables for storing the paren index list.
+;;;
+(defvar *regex-groups* (make-array 10))
+(defvar *regex-groupings* 0)
+
+;;;
+;;; Declare a simple interface for testing. You probably wouldn't want
+;;; to use this interface unless you were just calling this once.
+;;;
+(defun regex (expression string)
+ "Usage: (regex <expression> <string)
+ This function will call regex-compile on the expression and then apply
+ the string to the returned lambda list."
+ (let ((findit (cond ((stringp expression)
+ (regex-compile expression))
+ ((listp expression)
+ expression)))
+ (result nil))
+ (if (not (funcall (if (functionp findit)
+ findit
+ (eval `(function ,findit))) string))
+ (return-from regex nil))
+ (if (= *regex-groupings* 0)
+ (return-from regex t))
+ (dotimes (i *regex-groupings*)
+ (push (funcall 'subseq
+ string
+ (car (aref *regex-groups* i))
+ (cadr (aref *regex-groups* i)))
+ result))
+ (reverse result)))
+
+;;;
+;;; Declare some simple macros to make the code more readable.
+;;;
+(defvar *regex-special-chars* "?*+.()[]\\${}")
+
+(defmacro add-exp (list)
+ "Add an item to the end of expression"
+ `(setf expression (append expression ,list)))
+
+;;;
+;;; Define a function that will take a quoted character and return
+;;; what the real character should be plus how much of the source
+;;; string was used. If the result is a set of characters, return an
+;;; array of bits indicating which characters should be set. If the
+;;; expression is one of the sub-group matches return a
+;;; list-expression that will provide the match.
+;;;
+(defun regex-quoted (char-string &optional (invert nil))
+ "Usage: (regex-quoted <char-string> &optional invert)
+ Returns either the quoted character or a simple bit vector of bits set for
+ the matching values"
+ (let ((first (char char-string 0))
+ (result (char char-string 0))
+ (used-length 1))
+ (cond ((eql first #\n)
+ (setf result #\NewLine))
+ ((eql first #\c)
+ (setf result #\Return))
+ ((eql first #\t)
+ (setf result #\Tab))
+ ((eql first #\d)
+ (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\D)
+ (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((eql first #\w)
+ (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\W)
+ (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((eql first #\b)
+ (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\B)
+ (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((eql first #\s)
+ (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000))
+ ((eql first #\S)
+ (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111))
+ ((and (>= (char-code first) (char-code #\0))
+ (<= (char-code first) (char-code #\9)))
+ (if (and (> (length char-string) 2)
+ (and (>= (char-code (char char-string 1)) (char-code #\0))
+ (<= (char-code (char char-string 1)) (char-code #\9))
+ (>= (char-code (char char-string 2)) (char-code #\0))
+ (<= (char-code (char char-string 2)) (char-code #\9))))
+ ;;
+ ;; It is a single character specified in octal
+ ;;
+ (progn
+ (setf result (do ((x 0 (1+ x))
+ (return 0))
+ ((= x 2) return)
+ (setf return (+ (* return 8)
+ (- (char-code (char char-string x))
+ (char-code #\0))))))
+ (setf used-length 3))
+ ;;
+ ;; We have a group number replacement.
+ ;;
+ (let ((group (- (char-code first) (char-code #\0))))
+ (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group))
+ (cadr (aref *regex-groups* ,group)))))
+ (if (< length (+ index (length nstring)))
+ (return-from compare nil))
+ (if (not (string= string nstring
+ :start1 index
+ :end1 (+ index (length nstring))))
+ (return-from compare nil)
+ (incf index (length nstring)))))))))
+ (t
+ (setf result first)))
+ (if (and (vectorp result) invert)
+ (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t))
+ (values result used-length)))
+
+;;;
+;;; Now for the main regex compiler routine.
+;;;
+(defun regex-compile (source &key (anchored nil))
+ "Usage: (regex-compile <expression> [ :anchored (t/nil) ])
+ This function take a regular expression (supplied as source) and
+ compiles this into a lambda list that a string argument can then
+ be applied to. It is also possible to compile this lambda list
+ for better performance or to save it as a named function for later
+ use"
+ (info "Now entering regex-compile with \"~A\"~%" source)
+ ;;
+ ;; This routine works in two parts.
+ ;; The first pass take the regular expression and produces a list of
+ ;; operators and lisp expressions for the entire regular expression.
+ ;; The second pass takes this list and produces the lambda expression.
+ (let ((expression '()) ; holder for expressions
+ (group 1) ; Current group index
+ (group-stack nil) ; Stack of current group endings
+ (result nil) ; holder for built expression.
+ (fast-first nil)) ; holder for quick unanchored scan
+ ;;
+ ;; If the expression was an empty string then it alway
+ ;; matches (so lets leave early)
+ ;;
+ (if (= (length source) 0)
+ (return-from regex-compile
+ '(lambda (&rest args)
+ (declare (ignore args))
+ t)))
+ ;;
+ ;; If the first character is a caret then set the anchored
+ ;; flags and remove if from the expression string.
+ ;;
+ (cond ((eql (char source 0) #\^)
+ (setf source (subseq source 1))
+ (setf anchored t)))
+ ;;
+ ;; If the first sequence is .* then also set the anchored flags.
+ ;; (This is purely for optimization, it will work without this).
+ ;;
+ (if (>= (length source) 2)
+ (if (string= source ".*" :start1 0 :end1 2)
+ (setf anchored t)))
+ ;;
+ ;; Also, If this is not an anchored search and the first character is
+ ;; a literal, then do a quick scan to see if it is even in the string.
+ ;; If not then we can issue a quick nil,
+ ;; otherwise we can start the search at the matching character to skip
+ ;; the checks of the non-matching characters anyway.
+ ;;
+ ;; If I really wanted to speed up this section of code it would be
+ ;; easy to recognize the case of a fairly long multi-character literal
+ ;; and generate a Boyer-Moore search for the entire literal.
+ ;;
+ ;; I generate the code to do a loop because on CMU Lisp this is about
+ ;; twice as fast a calling position.
+ ;;
+ (if (and (not anchored)
+ (not (position (char source 0) *regex-special-chars*))
+ (not (and (> (length source) 1)
+ (position (char source 1) *regex-special-chars*))))
+ (setf fast-first `((if (not (dotimes (i length nil)
+ (if (eql (char string i)
+ ,(char source 0))
+ (return (setf start i)))))
+ (return-from final-return nil)))))
+ ;;
+ ;; Generate the very first expression to save the starting index
+ ;; so that group 0 will be the entire string matched always
+ ;;
+ (add-exp '((setf (aref *regex-groups* 0)
+ (list index nil))))
+ ;;
+ ;; Loop over each character in the regular expression building the
+ ;; expression list as we go.
+ ;;
+ (do ((eindex 0 (1+ eindex)))
+ ((= eindex (length source)))
+ (let ((current (char source eindex)))
+ (info "Now processing character ~A index = ~A~%" current eindex)
+ (case current
+ ((#\.)
+ ;;
+ ;; Generate code for a single wild character
+ ;;
+ (add-exp '((if (>= index length)
+ (return-from compare nil)
+ (incf index)))))
+ ((#\$)
+ ;;
+ ;; If this is the last character of the expression then
+ ;; anchor the end of the expression, otherwise let it slide
+ ;; as a standard character (even though it should be quoted).
+ ;;
+ (if (= eindex (1- (length source)))
+ (add-exp '((if (not (= index length))
+ (return-from compare nil))))
+ (add-exp '((if (not (and (< index length)
+ (eql (char string index) #\$)))
+ (return-from compare nil)
+ (incf index))))))
+ ((#\*)
+ (add-exp '(ASTRISK)))
+
+ ((#\+)
+ (add-exp '(PLUS)))
+
+ ((#\?)
+ (add-exp '(QUESTION)))
+
+ ((#\()
+ ;;
+ ;; Start a grouping.
+ ;;
+ (incf group)
+ (push group group-stack)
+ (add-exp `((setf (aref *regex-groups* ,(1- group))
+ (list index nil))))
+ (add-exp `(,group)))
+ ((#\))
+ ;;
+ ;; End a grouping
+ ;;
+ (let ((group (pop group-stack)))
+ (add-exp `((setf (cadr (aref *regex-groups* ,(1- group)))
+ index)))
+ (add-exp `(,(- group)))))
+ ((#\[)
+ ;;
+ ;; Start of a range operation.
+ ;; Generate a bit-vector that has one bit per possible character
+ ;; and then on each character or range, set the possible bits.
+ ;;
+ ;; If the first character is carat then invert the set.
+ (let* ((invert (eql (char source (1+ eindex)) #\^))
+ (bitstring (make-array 256 :element-type 'bit
+ :initial-element
+ (if invert 1 0)))
+ (set-char (if invert 0 1)))
+ (if invert (incf eindex))
+ (do ((x (1+ eindex) (1+ x)))
+ ((eql (char source x) #\]) (setf eindex x))
+ (info "Building range with character ~A~%" (char source x))
+ (cond ((and (eql (char source (1+ x)) #\-)
+ (not (eql (char source (+ x 2)) #\])))
+ (if (>= (char-code (char source x))
+ (char-code (char source (+ 2 x))))
+ (error "Invalid range \"~A-~A\". Ranges must be in acending order"
+ (char source x) (char source (+ 2 x))))
+ (do ((j (char-code (char source x)) (1+ j)))
+ ((> j (char-code (char source (+ 2 x))))
+ (incf x 2))
+ (info "Setting bit for char ~A code ~A~%" (code-char j) j)
+ (setf (sbit bitstring j) set-char)))
+ (t
+ (cond ((not (eql (char source x) #\]))
+ (let ((char (char source x)))
+ ;;
+ ;; If the character is quoted then find out what
+ ;; it should have been
+ ;;
+ (if (eql (char source x) #\\ )
+ (let ((length))
+ (multiple-value-setq (char length)
+ (regex-quoted (subseq source x) invert))
+ (incf x length)))
+ (info "Setting bit for char ~A code ~A~%" char (char-code char))
+ (if (not (vectorp char))
+ (setf (sbit bitstring (char-code (char source x))) set-char)
+ (bit-ior bitstring char t))))))))
+ (add-exp `((let ((range ,bitstring))
+ (if (>= index length)
+ (return-from compare nil))
+ (if (= 1 (sbit range (char-code (char string index))))
+ (incf index)
+ (return-from compare nil)))))))
+ ((#\\ )
+ ;;
+ ;; Intreprete the next character as a special, range, octal, group or
+ ;; just the character itself.
+ ;;
+ (let ((length)
+ (value))
+ (multiple-value-setq (value length)
+ (regex-quoted (subseq source (1+ eindex)) nil))
+ (cond ((listp value)
+ (add-exp value))
+ ((characterp value)
+ (add-exp `((if (not (and (< index length)
+ (eql (char string index)
+ ,value)))
+ (return-from compare nil)
+ (incf index)))))
+ ((vectorp value)
+ (add-exp `((let ((range ,value))
+ (if (>= index length)
+ (return-from compare nil))
+ (if (= 1 (sbit range (char-code (char string index))))
+ (incf index)
+ (return-from compare nil)))))))
+ (incf eindex length)))
+ (t
+ ;;
+ ;; We have a literal character.
+ ;; Scan to see how many we have and if it is more than one
+ ;; generate a string= verses as single eql.
+ ;;
+ (let* ((lit "")
+ (term (dotimes (litindex (- (length source) eindex) nil)
+ (let ((litchar (char source (+ eindex litindex))))
+ (if (position litchar *regex-special-chars*)
+ (return litchar)
+ (progn
+ (info "Now adding ~A index ~A to lit~%" litchar
+ litindex)
+ (setf lit (concatenate 'string lit
+ (string litchar)))))))))
+ (if (= (length lit) 1)
+ (add-exp `((if (not (and (< index length)
+ (eql (char string index) ,current)))
+ (return-from compare nil)
+ (incf index))))
+ ;;
+ ;; If we have a multi-character literal then we must
+ ;; check to see if the next character (if there is one)
+ ;; is an astrisk or a plus or a question mark. If so then we must not use this
+ ;; character in the big literal.
+ (progn
+ (if (or (eql term #\*)
+ (eql term #\+)
+ (eql term #\?))
+ (setf lit (subseq lit 0 (1- (length lit)))))
+ (add-exp `((if (< length (+ index ,(length lit)))
+ (return-from compare nil))
+ (if (not (string= string ,lit :start1 index
+ :end1 (+ index ,(length lit))))
+ (return-from compare nil)
+ (incf index ,(length lit)))))))
+ (incf eindex (1- (length lit))))))))
+ ;;
+ ;; Plug end of list to return t. If we made it this far then
+ ;; We have matched!
+ (add-exp '((setf (cadr (aref *regex-groups* 0))
+ index)))
+ (add-exp '((return-from final-return t)))
+ ;;
+;;; (print expression)
+ ;;
+ ;; Now take the expression list and turn it into a lambda expression
+ ;; replacing the special flags with lisp code.
+ ;; For example: A BEGIN needs to be replace by an expression that
+ ;; saves the current index, then evaluates everything till it gets to
+ ;; the END then save the new index if it didn't fail.
+ ;; On an ASTRISK I need to take the previous expression and wrap
+ ;; it in a do that will evaluate the expression till an error
+ ;; occurs and then another do that encompases the remainder of the
+ ;; regular expression and iterates decrementing the index by one
+ ;; of the matched expression sizes and then returns nil. After
+ ;; the last expression insert a form that does a return t so that
+ ;; if the entire nested sub-expression succeeds then the loop
+ ;; is broken manually.
+ ;;
+ (setf result (copy-tree nil))
+ ;;
+ ;; Reversing the current expression makes building up the
+ ;; lambda list easier due to the nexting of expressions when
+ ;; and astrisk has been encountered.
+ (setf expression (reverse expression))
+ (do ((elt 0 (1+ elt)))
+ ((>= elt (length expression)))
+ (let ((piece (nth elt expression)))
+ ;;
+ ;; Now check for PLUS, if so then ditto the expression and then let the
+ ;; ASTRISK below handle the rest.
+ ;;
+ (cond ((eql piece 'PLUS)
+ (cond ((listp (nth (1+ elt) expression))
+ (setf result (append (list (nth (1+ elt) expression))
+ result)))
+ ;;
+ ;; duplicate the entire group
+ ;; NOTE: This hasn't been implemented yet!!
+ (t
+ (error "GROUP repeat hasn't been implemented yet~%")))))
+ (cond ((listp piece) ;Just append the list
+ (setf result (append (list piece) result)))
+ ((eql piece 'QUESTION) ; Wrap it in a block that won't fail
+ (cond ((listp (nth (1+ elt) expression))
+ (setf result
+ (append `((progn (block compare
+ ,(nth (1+ elt)
+ expression))
+ t))
+ result))
+ (incf elt))
+ ;;
+ ;; This is a QUESTION on an entire group which
+ ;; hasn't been implemented yet!!!
+ ;;
+ (t
+ (error "Optional groups not implemented yet~%"))))
+ ((or (eql piece 'ASTRISK) ; Do the wild thing!
+ (eql piece 'PLUS))
+ (cond ((listp (nth (1+ elt) expression))
+ ;;
+ ;; This is a single character wild card so
+ ;; do the simple form.
+ ;;
+ (setf result
+ `((let ((oindex index))
+ (block compare
+ (do ()
+ (nil)
+ ,(nth (1+ elt) expression)))
+ (do ((start index (1- start)))
+ ((< start oindex) nil)
+ (let ((index start))
+ (block compare
+ ,@result))))))
+ (incf elt))
+ (t
+ ;;
+ ;; This is a subgroup repeated so I must build
+ ;; the loop using several values.
+ ;;
+ ))
+ )
+ (t t)))) ; Just ignore everything else.
+ ;;
+ ;; Now wrap the result in a lambda list that can then be
+ ;; invoked or compiled, however the user wishes.
+ ;;
+ (if anchored
+ (setf result
+ `(lambda (string &key (start 0) (end (length string)))
+ (setf *regex-groupings* ,group)
+ (block final-return
+ (block compare
+ (let ((index start)
+ (length end))
+ ,@result)))))
+ (setf result
+ `(lambda (string &key (start 0) (end (length string)))
+ (setf *regex-groupings* ,group)
+ (block final-return
+ (let ((length end))
+ ,@fast-first
+ (do ((marker start (1+ marker)))
+ ((> marker end) nil)
+ (let ((index marker))
+ (if (block compare
+ ,@result)
+ (return t)))))))))))
+
+;; (provide 'nregex)
Added: branches/bos/thirdparty/emacs/slime/sbcl-pprint-patch.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/sbcl-pprint-patch.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,332 @@
+;; Pretty printer patch for SBCL, which adds the "annotations" feature
+;; required for sending presentations through pretty-printing streams.
+;;
+;; The section marked "Changed functions" and the DEFSTRUCT
+;; PRETTY-STREAM are based on SBCL's pprint.lisp.
+;;
+;; Public domain.
+
+(in-package "SB!PRETTY")
+
+(defstruct (annotation (:include queued-op))
+ (handler (constantly nil) :type function)
+ (record))
+
+
+(defstruct (pretty-stream (:include sb!kernel:ansi-stream
+ (out #'pretty-out)
+ (sout #'pretty-sout)
+ (misc #'pretty-misc))
+ (:constructor make-pretty-stream (target))
+ (:copier nil))
+ ;; Where the output is going to finally go.
+ (target (missing-arg) :type stream)
+ ;; Line length we should format to. Cached here so we don't have to keep
+ ;; extracting it from the target stream.
+ (line-length (or *print-right-margin*
+ (sb!impl::line-length target)
+ default-line-length)
+ :type column)
+ ;; A simple string holding all the text that has been output but not yet
+ ;; printed.
+ (buffer (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; The index into BUFFER where more text should be put.
+ (buffer-fill-pointer 0 :type index)
+ ;; Whenever we output stuff from the buffer, we shift the remaining noise
+ ;; over. This makes it difficult to keep references to locations in
+ ;; the buffer. Therefore, we have to keep track of the total amount of
+ ;; stuff that has been shifted out of the buffer.
+ (buffer-offset 0 :type posn)
+ ;; The column the first character in the buffer will appear in. Normally
+ ;; zero, but if we end up with a very long line with no breaks in it we
+ ;; might have to output part of it. Then this will no longer be zero.
+ (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
+ ;; The line number we are currently on. Used for *PRINT-LINES*
+ ;; abbreviations and to tell when sections have been split across
+ ;; multiple lines.
+ (line-number 0 :type index)
+ ;; the value of *PRINT-LINES* captured at object creation time. We
+ ;; use this, instead of the dynamic *PRINT-LINES*, to avoid
+ ;; weirdness like
+ ;; (let ((*print-lines* 50))
+ ;; (pprint-logical-block ..
+ ;; (dotimes (i 10)
+ ;; (let ((*print-lines* 8))
+ ;; (print (aref possiblybigthings i) prettystream)))))
+ ;; terminating the output of the entire logical blockafter 8 lines.
+ (print-lines *print-lines* :type (or index null) :read-only t)
+ ;; Stack of logical blocks in effect at the buffer start.
+ (blocks (list (make-logical-block)) :type list)
+ ;; Buffer holding the per-line prefix active at the buffer start.
+ ;; Indentation is included in this. The length of this is stored
+ ;; in the logical block stack.
+ (prefix (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; Buffer holding the total remaining suffix active at the buffer start.
+ ;; The characters are right-justified in the buffer to make it easier
+ ;; to output the buffer. The length is stored in the logical block
+ ;; stack.
+ (suffix (make-string initial-buffer-size) :type (simple-array character (*)))
+ ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
+ ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
+ ;; cons. Adding things to the queue is basically (setf (cdr head) (list
+ ;; new)) and removing them is basically (pop tail) [except that care must
+ ;; be taken to handle the empty queue case correctly.]
+ (queue-tail nil :type list)
+ (queue-head nil :type list)
+ ;; Block-start queue entries in effect at the queue head.
+ (pending-blocks nil :type list)
+ ;; Queue of annotations to the buffer
+ (annotations-tail nil :type list)
+ (annotations-head nil :type list))
+
+
+(defmacro enqueue (stream type &rest args)
+ (let ((constructor (intern (concatenate 'string
+ "MAKE-"
+ (symbol-name type))
+ "SB-PRETTY")))
+ (once-only ((stream stream)
+ (entry `(,constructor :posn
+ (index-posn
+ (pretty-stream-buffer-fill-pointer
+ ,stream)
+ ,stream)
+ ,@args))
+ (op `(list ,entry))
+ (head `(pretty-stream-queue-head ,stream)))
+ `(progn
+ (if ,head
+ (setf (cdr ,head) ,op)
+ (setf (pretty-stream-queue-tail ,stream) ,op))
+ (setf (pretty-stream-queue-head ,stream) ,op)
+ ,entry))))
+
+;;;
+;;; New helper functions
+;;;
+
+(defun enqueue-annotation (stream handler record)
+ (enqueue stream annotation :handler handler
+ :record record))
+
+(defun re-enqueue-annotation (stream annotation)
+ (let* ((annotation-cons (list annotation))
+ (head (pretty-stream-annotations-head stream)))
+ (if head
+ (setf (cdr head) annotation-cons)
+ (setf (pretty-stream-annotations-tail stream) annotation-cons))
+ (setf (pretty-stream-annotations-head stream) annotation-cons)
+ nil))
+
+(defun re-enqueue-annotations (stream end)
+ (loop for tail = (pretty-stream-queue-tail stream) then (cdr tail)
+ while (and tail (not (eql (car tail) end)))
+ when (annotation-p (car tail))
+ do (re-enqueue-annotation stream (car tail))))
+
+(defun dequeue-annotation (stream &key end-posn)
+ (let ((next-annotation (car (pretty-stream-annotations-tail stream))))
+ (when next-annotation
+ (when (or (not end-posn)
+ (<= (annotation-posn next-annotation) end-posn))
+ (pop (pretty-stream-annotations-tail stream))
+ (unless (pretty-stream-annotations-tail stream)
+ (setf (pretty-stream-annotations-head stream) nil))
+ next-annotation))))
+
+(defun invoke-annotation (stream annotation truncatep)
+ (let ((target (pretty-stream-target stream)))
+ (funcall (annotation-handler annotation)
+ (annotation-record annotation)
+ target
+ truncatep)))
+
+(defun output-buffer-with-annotations (stream end)
+ (let ((target (pretty-stream-target stream))
+ (buffer (pretty-stream-buffer stream))
+ (end-posn (index-posn end stream))
+ (start 0))
+ (loop
+ for annotation = (dequeue-annotation stream :end-posn end-posn)
+ while annotation
+ do
+ (let ((annotation-index (posn-index (annotation-posn annotation)
+ stream)))
+ (when (> annotation-index start)
+ (write-string buffer target :start start
+ :end annotation-index)
+ (setf start annotation-index))
+ (invoke-annotation stream annotation nil)))
+ (when (> end start)
+ (write-string buffer target :start start :end end))))
+
+(defun flush-annotations (stream end truncatep)
+ (let ((end-posn (index-posn end stream)))
+ (loop
+ for annotation = (dequeue-annotation stream :end-posn end-posn)
+ while annotation
+ do (invoke-annotation stream annotation truncatep))))
+
+;;;
+;;; Changed functions
+;;;
+
+(defun maybe-output (stream force-newlines-p)
+ (declare (type pretty-stream stream))
+ (let ((tail (pretty-stream-queue-tail stream))
+ (output-anything nil))
+ (loop
+ (unless tail
+ (setf (pretty-stream-queue-head stream) nil)
+ (return))
+ (let ((next (pop tail)))
+ (etypecase next
+ (newline
+ (when (ecase (newline-kind next)
+ ((:literal :mandatory :linear) t)
+ (:miser (misering-p stream))
+ (:fill
+ (or (misering-p stream)
+ (> (pretty-stream-line-number stream)
+ (logical-block-section-start-line
+ (first (pretty-stream-blocks stream))))
+ (ecase (fits-on-line-p stream
+ (newline-section-end next)
+ force-newlines-p)
+ ((t) nil)
+ ((nil) t)
+ (:dont-know
+ (return))))))
+ (setf output-anything t)
+ (output-line stream next)))
+ (indentation
+ (unless (misering-p stream)
+ (set-indentation stream
+ (+ (ecase (indentation-kind next)
+ (:block
+ (logical-block-start-column
+ (car (pretty-stream-blocks stream))))
+ (:current
+ (posn-column
+ (indentation-posn next)
+ stream)))
+ (indentation-amount next)))))
+ (block-start
+ (ecase (fits-on-line-p stream (block-start-section-end next)
+ force-newlines-p)
+ ((t)
+ ;; Just nuke the whole logical block and make it look like one
+ ;; nice long literal. (But don't nuke annotations.)
+ (let ((end (block-start-block-end next)))
+ (expand-tabs stream end)
+ (re-enqueue-annotations stream end)
+ (setf tail (cdr (member end tail)))))
+ ((nil)
+ (really-start-logical-block
+ stream
+ (posn-column (block-start-posn next) stream)
+ (block-start-prefix next)
+ (block-start-suffix next)))
+ (:dont-know
+ (return))))
+ (block-end
+ (really-end-logical-block stream))
+ (tab
+ (expand-tabs stream next))
+ (annotation
+ (re-enqueue-annotation stream next))))
+ (setf (pretty-stream-queue-tail stream) tail))
+ output-anything))
+
+(defun output-line (stream until)
+ (declare (type pretty-stream stream)
+ (type newline until))
+ (let* ((target (pretty-stream-target stream))
+ (buffer (pretty-stream-buffer stream))
+ (kind (newline-kind until))
+ (literal-p (eq kind :literal))
+ (amount-to-consume (posn-index (newline-posn until) stream))
+ (amount-to-print
+ (if literal-p
+ amount-to-consume
+ (let ((last-non-blank
+ (position #\space buffer :end amount-to-consume
+ :from-end t :test #'char/=)))
+ (if last-non-blank
+ (1+ last-non-blank)
+ 0)))))
+ (output-buffer-with-annotations stream amount-to-print)
+ (flush-annotations stream amount-to-consume nil)
+ (let ((line-number (pretty-stream-line-number stream)))
+ (incf line-number)
+ (when (and (not *print-readably*)
+ (pretty-stream-print-lines stream)
+ (>= line-number (pretty-stream-print-lines stream)))
+ (write-string " .." target)
+ (flush-annotations stream
+ (pretty-stream-buffer-fill-pointer stream)
+ t)
+ (let ((suffix-length (logical-block-suffix-length
+ (car (pretty-stream-blocks stream)))))
+ (unless (zerop suffix-length)
+ (let* ((suffix (pretty-stream-suffix stream))
+ (len (length suffix)))
+ (write-string suffix target
+ :start (- len suffix-length)
+ :end len))))
+ (throw 'line-limit-abbreviation-happened t))
+ (setf (pretty-stream-line-number stream) line-number)
+ (write-char #\newline target)
+ (setf (pretty-stream-buffer-start-column stream) 0)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (block (first (pretty-stream-blocks stream)))
+ (prefix-len
+ (if literal-p
+ (logical-block-per-line-prefix-end block)
+ (logical-block-prefix-length block)))
+ (shift (- amount-to-consume prefix-len))
+ (new-fill-ptr (- fill-ptr shift))
+ (new-buffer buffer)
+ (buffer-length (length buffer)))
+ (when (> new-fill-ptr buffer-length)
+ (setf new-buffer
+ (make-string (max (* buffer-length 2)
+ (+ buffer-length
+ (floor (* (- new-fill-ptr buffer-length)
+ 5)
+ 4)))))
+ (setf (pretty-stream-buffer stream) new-buffer))
+ (replace new-buffer buffer
+ :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+ (replace new-buffer (pretty-stream-prefix stream)
+ :end1 prefix-len)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) shift)
+ (unless literal-p
+ (setf (logical-block-section-column block) prefix-len)
+ (setf (logical-block-section-start-line block) line-number))))))
+
+(defun output-partial-line (stream)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (tail (pretty-stream-queue-tail stream))
+ (count
+ (if tail
+ (posn-index (queued-op-posn (car tail)) stream)
+ fill-ptr))
+ (new-fill-ptr (- fill-ptr count))
+ (buffer (pretty-stream-buffer stream)))
+ (when (zerop count)
+ (error "Output-partial-line called when nothing can be output."))
+ (output-buffer-with-annotations stream count)
+ (incf (pretty-stream-buffer-start-column stream) count)
+ (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) count)))
+
+(defun force-pretty-output (stream)
+ (maybe-output stream nil)
+ (expand-tabs stream nil)
+ (re-enqueue-annotations stream nil)
+ (output-buffer-with-annotations stream
+ (pretty-stream-buffer-fill-pointer stream)))
+
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/slime-autoloads.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/slime-autoloads.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,50 @@
+;;; slime-autoloads.el --- autoload definitions for SLIME
+
+;; Copyright (C) 2007 Helmut Eller
+
+;; This file is protected by the GNU GPLv2 (or later), as distributed
+;; with GNU Emacs.
+
+;;; Commentary:
+
+;; This code defines the necessary autoloads, so that we don't need to
+;; load everything from .emacs.
+
+;;; Code:
+
+(autoload 'slime "slime"
+ "Start a Lisp subprocess and connect to its Swank server." t)
+
+(autoload 'slime-mode "slime"
+ "SLIME: The Superior Lisp Interaction (Minor) Mode for Emacs." t)
+
+(autoload 'slime-connect "slime"
+ "Connect to a running Swank server." t)
+
+(autoload 'hyperspec-lookup "hyperspec" nil t)
+
+(autoload 'slime-lisp-mode-hook "slime")
+(autoload 'slime-scheme-mode-hook "slime")
+
+(defvar slime-lisp-modes '(lisp-mode))
+
+(defun slime-setup (&optional contribs)
+ "Setup Emacs so that lisp-mode buffers always use SLIME.
+CONTRIBS is a list of contrib packages to load."
+ (when (member 'lisp-mode slime-lisp-modes)
+ (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook))
+ (setq slime-setup-contribs contribs)
+ (add-hook 'slime-load-hook 'slime-setup-contribs))
+
+(defvar slime-setup-contribs nil)
+
+(defun slime-setup-contribs ()
+ (dolist (c slime-setup-contribs)
+ (require c)
+ (let ((init (intern (format "%s-init" c))))
+ (when (fboundp init)
+ (funcall init)))))
+
+(provide 'slime-autoloads)
+
+;;; slime-autoloads.el ends here
Added: branches/bos/thirdparty/emacs/slime/slime.el
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/slime.el Fri Jan 18 06:05:59 2008
@@ -0,0 +1,9602 @@
+;;; slime.el --- Superior Lisp Interaction Mode for Emacs
+;;
+;;;; License
+;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
+;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;; MA 02111-1307, USA.
+
+
+;;;; Commentary
+;;
+;; This file contains extensions for programming in Common Lisp. The
+;; main features are:
+;;
+;; A socket-based communication/RPC interface between Emacs and
+;; Lisp.
+;;
+;; The `slime-mode' minor-mode complementing `lisp-mode'. This new
+;; mode includes many commands for interacting with the Common Lisp
+;; process.
+;;
+;; Common Lisp REPL (Read-Eval-Print Loop) written in Emacs Lisp,
+;; similar to `ielm'.
+;;
+;; Common Lisp debugger written in Emacs Lisp. The debugger pops up
+;; an Emacs buffer similar to the Emacs/Elisp debugger.
+;;
+;; Trapping compiler messages and creating annotations in the source
+;; file on the appropriate forms.
+;;
+;; SLIME is compatible with GNU Emacs 20 and 21 and XEmacs 21. In
+;; order to run SLIME requires a supporting Lisp server called
+;; Swank. Swank is distributed with slime.el and will automatically be
+;; started in a normal installation.
+
+
+;;;; Dependencies and setup
+
+(eval-and-compile
+ (require 'cl)
+ (unless (fboundp 'define-minor-mode)
+ (require 'easy-mmode)
+ (defalias 'define-minor-mode 'easy-mmode-define-minor-mode)))
+(require 'comint)
+(require 'timer)
+(require 'pp)
+(require 'hideshow)
+(require 'hyperspec)
+(require 'font-lock)
+(when (featurep 'xemacs)
+ (require 'overlay))
+(require 'easymenu)
+
+(defvar slime-lisp-modes '(lisp-mode))
+
+(defun slime-setup (&optional contribs)
+ "Setup Emacs so that lisp-mode buffers always use SLIME.
+CONTRIBS is a list of contrib packages to load."
+ (when (member 'lisp-mode slime-lisp-modes)
+ (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook))
+ (dolist (c contribs)
+ (require c)
+ (let ((init (intern (format "%s-init" c))))
+ (when (fboundp init)
+ (funcall init)))))
+
+(defun slime-lisp-mode-hook ()
+ (slime-mode 1)
+ (set (make-local-variable 'lisp-indent-function)
+ 'common-lisp-indent-function))
+
+(eval-and-compile
+ (defvar slime-path
+ (let ((path (or (locate-library "slime") load-file-name)))
+ (and path (file-name-directory path)))
+ "Directory containing the Slime package.
+This is used to load the supporting Common Lisp library, Swank.
+The default value is automatically computed from the location of the
+Emacs Lisp package."))
+
+(eval-and-compile
+ (defun slime-changelog-date ()
+ "Return the datestring of the latest entry in the ChangeLog file.
+Return nil if the ChangeLog file cannot be found."
+ (let ((changelog (concat slime-path "ChangeLog")))
+ (if (file-exists-p changelog)
+ (with-temp-buffer
+ (insert-file-contents changelog nil 0 100)
+ (goto-char (point-min))
+ (symbol-name (read (current-buffer))))
+ nil))))
+
+(defvar slime-protocol-version nil)
+(setq slime-protocol-version
+ (eval-when-compile (slime-changelog-date)))
+
+
+;;;; Customize groups
+;;
+;;;;; slime
+
+(defgroup slime nil
+ "Interaction with the Superior Lisp Environment."
+ :prefix "slime-"
+ :group 'applications)
+
+;;;;; slime-ui
+
+(defgroup slime-ui nil
+ "Interaction with the Superior Lisp Environment."
+ :prefix "slime-"
+ :group 'slime)
+
+(defcustom slime-truncate-lines t
+ "Set `truncate-lines' in popup buffers.
+This applies to buffers that present lines as rows of data, such as
+debugger backtraces and apropos listings."
+ :type 'boolean
+ :group 'slime-ui)
+
+(defcustom slime-update-modeline-package t
+ "Automatically update the Lisp package name in the minibuffer.
+This is done with a text-search that runs on an idle timer."
+ :type 'boolean
+ :group 'slime-ui)
+
+(defcustom slime-kill-without-query-p nil
+ "If non-nil, kill SLIME processes without query when quitting Emacs.
+This applies to the *inferior-lisp* buffer and the network connections."
+ :type 'boolean
+ :group 'slime-ui)
+
+;;;;; slime-lisp
+
+(defgroup slime-lisp nil
+ "Lisp server configuration."
+ :prefix "slime-"
+ :group 'slime)
+
+(defcustom slime-backend "swank-loader.lisp"
+ "The name of the Lisp file that loads the Swank server.
+This name is interpreted relative to the directory containing
+slime.el, but could also be set to an absolute filename."
+ :type 'string
+ :group 'slime-lisp)
+
+(defcustom slime-connected-hook nil
+ "List of functions to call when SLIME connects to Lisp."
+ :type 'hook
+ :group 'slime-lisp)
+
+(defcustom slime-filename-translations nil
+ "Assoc list of hostnames and filename translation functions.
+Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP).
+
+HOSTNAME-REGEXP is a regexp which is applied to the connection's
+slime-machine-instance. If HOSTNAME-REGEXP maches then the
+corresponding TO-LISP and FROM-LISP functions will be used to
+translate emacs filenames and lisp filenames.
+
+TO-LISP will be passed the filename of an emacs buffer and must
+return a string which the underlying lisp understandas as a
+pathname. FROM-LISP will be passed a pathname as returned by the
+underlying lisp and must return something that emacs will
+understand as a filename (this string will be passed to
+find-file).
+
+This list will be traversed in order, so multiple matching
+regexps are possible.
+
+Example:
+
+Assuming you run emacs locally and connect to slime running on
+the machine 'soren' and you can connect with the username
+'animaliter':
+
+ (push (list \"^soren$\"
+ (lambda (emacs-filename)
+ (subseq emacs-filename (length \"/ssh:animaliter@soren:\")))
+ (lambda (lisp-filename)
+ (concat \"/ssh:animaliter@soren:\" lisp-filename)))
+ slime-filename-translations)
+
+See also `slime-create-filename-translator'."
+ :type '(repeat (list :tag "Host description"
+ (regexp :tag "Hostname regexp")
+ (function :tag "To lisp function")
+ (function :tag "From lisp function")))
+ :group 'slime-lisp)
+
+(defcustom slime-enable-evaluate-in-emacs nil
+ "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs.
+The default is nil, as this feature can be a security risk."
+ :type '(boolean)
+ :group 'slime-lisp)
+
+;;;;; slime-mode
+
+(defgroup slime-mode nil
+ "Settings for slime-mode Lisp source buffers."
+ :prefix "slime-"
+ :group 'slime)
+
+(defcustom slime-edit-definition-fallback-function nil
+ "Function to call when edit-definition fails to find the source itself.
+The function is called with the definition name, a string, as its argument.
+
+If you want to fallback on TAGS you can set this to `find-tag',
+`slime-find-tag-if-tags-table-visited', or
+`slime-edit-definition-with-etags'."
+ :type 'symbol
+ :group 'slime-mode-mode
+ :options '(nil
+ slime-edit-definition-with-etags
+ slime-find-tag-if-tags-table-visited
+ find-tag))
+
+(defcustom slime-complete-symbol-function 'slime-simple-complete-symbol
+ "*Function to perform symbol completion."
+ :group 'slime-mode
+ :type '(choice (const :tag "Simple" slime-simple-complete-symbol)
+ (const :tag "Compound" slime-complete-symbol*)
+ (const :tag "Fuzzy" slime-fuzzy-complete-symbol)))
+
+(defcustom slime-when-complete-filename-expand nil
+ "Use comint-replace-by-expanded-filename instead of comint-dynamic-complete-as-filename to complete file names"
+ :group 'slime-mode
+ :type 'boolean)
+
+(defcustom slime-space-information-p t
+ "Have the SPC key offer arglist information."
+ :type 'boolean
+ :group 'slime-mode)
+
+;;;;; slime-mode-faces
+
+(defgroup slime-mode-faces nil
+ "Faces in slime-mode source code buffers."
+ :prefix "slime-"
+ :group 'slime-mode)
+
+(defun slime-underline-color (color)
+ "Return a legal value for the :underline face attribute based on COLOR."
+ ;; In XEmacs the :underline attribute can only be a boolean.
+ ;; In GNU it can be the name of a colour.
+ (if (featurep 'xemacs)
+ (if color t nil)
+ color))
+
+(defface slime-error-face
+ `((((class color) (background light))
+ (:underline ,(slime-underline-color "red")))
+ (((class color) (background dark))
+ (:underline ,(slime-underline-color "red")))
+ (t (:underline t)))
+ "Face for errors from the compiler."
+ :group 'slime-mode-faces)
+
+(defface slime-warning-face
+ `((((class color) (background light))
+ (:underline ,(slime-underline-color "orange")))
+ (((class color) (background dark))
+ (:underline ,(slime-underline-color "coral")))
+ (t (:underline t)))
+ "Face for warnings from the compiler."
+ :group 'slime-mode-faces)
+
+(defface slime-style-warning-face
+ `((((class color) (background light))
+ (:underline ,(slime-underline-color "brown")))
+ (((class color) (background dark))
+ (:underline ,(slime-underline-color "gold")))
+ (t (:underline t)))
+ "Face for style-warnings from the compiler."
+ :group 'slime-mode-faces)
+
+(defface slime-note-face
+ `((((class color) (background light))
+ (:underline ,(slime-underline-color "brown4")))
+ (((class color) (background dark))
+ (:underline ,(slime-underline-color "light goldenrod")))
+ (t (:underline t)))
+ "Face for notes from the compiler."
+ :group 'slime-mode-faces)
+
+(defun slime-face-inheritance-possible-p ()
+ "Return true if the :inherit face attribute is supported."
+ (assq :inherit custom-face-attributes))
+
+(defface slime-highlight-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit highlight :underline nil)))
+ '((((class color) (background light))
+ (:background "darkseagreen2"))
+ (((class color) (background dark))
+ (:background "darkolivegreen"))
+ (t (:inverse-video t))))
+ "Face for compiler notes while selected."
+ :group 'slime-mode-faces)
+
+;;;;; sldb
+
+(defgroup slime-debugger nil
+ "Backtrace options and fontification."
+ :prefix "sldb-"
+ :group 'slime)
+
+(defmacro define-sldb-faces (&rest faces)
+ "Define the set of SLDB faces.
+Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES).
+NAME is a symbol; the face will be called sldb-NAME-face.
+DESCRIPTION is a one-liner for the customization buffer.
+PROPERTIES specifies any default face properties."
+ `(progn ,@(loop for face in faces
+ collect `(define-sldb-face ,@face))))
+
+(defmacro define-sldb-face (name description &optional default)
+ (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))))
+ `(defface ,facename
+ (list (list t ,default))
+ ,(format "Face for %s." description)
+ :group 'slime-debugger)))
+
+(define-sldb-faces
+ (topline "the top line describing the error")
+ (condition "the condition class")
+ (section "the labels of major sections in the debugger buffer")
+ (frame-label "backtrace frame numbers")
+ (restart-type "restart names."
+ (if (slime-face-inheritance-possible-p)
+ '(:inherit font-lock-keyword-face)))
+ (restart "restart descriptions")
+ (restart-number "restart numbers (correspond to keystrokes to invoke)"
+ '(:bold t))
+ (frame-line "function names and arguments in the backtrace")
+ (detailed-frame-line
+ "function names and arguments in a detailed (expanded) frame")
+ (local-name "local variable names")
+ (local-value "local variable values")
+ (catch-tag "catch tags"))
+
+;;;;; slime-repl
+
+(defgroup slime-repl nil
+ "The Read-Eval-Print Loop (*slime-repl* buffer)."
+ :prefix "slime-repl-"
+ :group 'slime)
+
+(defcustom slime-repl-shortcut-dispatch-char ?\,
+ "Character used to distinguish repl commands from lisp forms."
+ :type '(character)
+ :group 'slime-repl)
+
+(defcustom slime-repl-only-save-lisp-buffers t
+ "When T we only attempt to save lisp-mode file buffers. When
+ NIL slime will attempt to save all buffers (as per
+ save-some-buffers). This applies to all ASDF related repl
+ shortcuts."
+ :type '(boolean)
+ :group 'slime-repl)
+
+(defcustom slime-repl-return-behaviour :send-if-complete
+ "Keyword specifying how slime-repl-return behaves when the
+ point is on a lisp expression (as opposed to being on a
+ previous output).
+
+Currently only two values are supported:
+
+:send-if-complete - If the current expression is complete, as per
+slime-input-complete-p, it is sent to the underlying lisp,
+otherwise a newline is inserted. The current value of (point) has
+no effect.
+
+:send-only-if-after-complete - If the current expression is complete
+and point is after the expression it is sent, otherwise a newline
+is inserted."
+ :type '(choice (const :tag "Send if complete" :value :send-if-complete)
+ (const :tag "Send only if after complete" :value :send-only-if-after-complete))
+ :group 'slime-repl)
+
+
+(defface slime-repl-prompt-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit font-lock-keyword-face)))
+ '((((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (t (:weight bold))))
+ "Face for the prompt in the SLIME REPL."
+ :group 'slime-repl)
+
+(defface slime-repl-output-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit font-lock-string-face)))
+ '((((class color) (background light)) (:foreground "RosyBrown"))
+ (((class color) (background dark)) (:foreground "LightSalmon"))
+ (t (:slant italic))))
+ "Face for Lisp output in the SLIME REPL."
+ :group 'slime-repl)
+
+(defface slime-repl-input-face
+ '((t (:bold t)))
+ "Face for previous input in the SLIME REPL."
+ :group 'slime-repl)
+
+(defface slime-repl-result-face
+ '((t ()))
+ "Face for the result of an evaluation in the SLIME REPL."
+ :group 'slime-repl)
+
+(defcustom slime-repl-history-file "~/.slime-history.eld"
+ "File to save the persistent REPL history to."
+ :type 'string
+ :group 'slime-repl)
+
+(defcustom slime-repl-history-size 200
+ "*Maximum number of lines for persistent REPL history."
+ :type 'integer
+ :group 'slime-repl)
+
+
+;;;; Minor modes
+
+;;;;; slime-mode
+
+(define-minor-mode slime-mode
+ "\\<slime-mode-map>\
+SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).
+
+Commands to compile the current buffer's source file and visually
+highlight any resulting compiler notes and warnings:
+\\[slime-compile-and-load-file] - Compile and load the current buffer's file.
+\\[slime-compile-file] - Compile (but not load) the current buffer's file.
+\\[slime-compile-defun] - Compile the top-level form at point.
+
+Commands for visiting compiler notes:
+\\[slime-next-note] - Goto the next form with a compiler note.
+\\[slime-previous-note] - Goto the previous form with a compiler note.
+\\[slime-remove-notes] - Remove compiler-note annotations in buffer.
+
+Finding definitions:
+\\[slime-edit-definition] - Edit the definition of the function called at point.
+\\[slime-pop-find-definition-stack] - Pop the definition stack to go back from a definition.
+
+Documentation commands:
+\\[slime-describe-symbol] - Describe symbol.
+\\[slime-apropos] - Apropos search.
+\\[slime-disassemble-symbol] - Disassemble a function.
+
+Evaluation commands:
+\\[slime-eval-defun] - Evaluate top-level from containing point.
+\\[slime-eval-last-expression] - Evaluate sexp before point.
+\\[slime-pprint-eval-last-expression] - Evaluate sexp before point, pretty-print result.
+
+Full set of commands:
+\\{slime-mode-map}"
+ nil
+ nil
+ ;; Fake binding to coax `define-minor-mode' to create the keymap
+ '((" " 'undefined)))
+
+(make-variable-buffer-local
+ (defvar slime-modeline-package nil
+ "The Lisp package to show in the modeline.
+This is automatically updated based on the buffer/point."))
+
+(defun slime-update-modeline-package ()
+ (ignore-errors
+ (when (and slime-update-modeline-package
+ (memq major-mode slime-lisp-modes)
+ slime-mode)
+ (let ((package (slime-current-package)))
+ (when package
+ (setq slime-modeline-package
+ (slime-pretty-package-name package)))))))
+
+(defun slime-pretty-package-name (name)
+ "Return a pretty version of a package name NAME."
+ (let ((name (cond ((string-match "^#?:\\(.*\\)$" name)
+ (match-string 1 name))
+ ((string-match "^\"\\(.*\\)\"$" name)
+ (match-string 1 name))
+ (t name))))
+ (format "%s" (read name))))
+
+(defun slime-pretty-find-buffer-package ()
+ "Return a prettied version of `slime-find-buffer-package'."
+ (let ((p (slime-find-buffer-package)))
+ (and p (slime-pretty-package-name p))))
+
+(when slime-update-modeline-package
+ (run-with-idle-timer 0.2 0.2 'slime-update-modeline-package))
+
+;; 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
+ '(slime-mode
+ (" Slime"
+ ((slime-modeline-package (":" slime-modeline-package) "")
+ slime-state-name))))
+
+(defun slime-input-complete-p (start end)
+ "Return t if the region from START to END contains a complete sexp."
+ (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))))
+
+
+;;;;; Key bindings
+
+;; See `slime-define-key' below for keyword meanings.
+(defvar slime-keys
+ '(;; Compiler notes
+ ("\M-p" slime-previous-note)
+ ("\M-n" slime-next-note)
+ ("\M-c" slime-remove-notes :prefixed t)
+ ("\C-k" slime-compile-and-load-file :prefixed t)
+ ("\M-k" slime-compile-file :prefixed t)
+ ("\C-c" slime-compile-defun :prefixed t)
+ ("\C-l" slime-load-file :prefixed t)
+ ;; Editing/navigating
+ ("\M-\C-i" slime-complete-symbol :inferior t)
+ ("\C-i" slime-complete-symbol :prefixed t :inferior t)
+ ("\M-." slime-edit-definition :inferior t :sldb t)
+ ("\C-x4." slime-edit-definition-other-window :inferior t :sldb t)
+ ("\C-x5." slime-edit-definition-other-frame :inferior t :sldb t)
+ ("\M-," slime-pop-find-definition-stack :inferior t :sldb t)
+ ;; Evaluating
+ ("\C-x\C-e" slime-eval-last-expression :inferior t)
+ ("\C-x\M-e" slime-eval-last-expression-display-output :inferior t)
+ ("\C-p" slime-pprint-eval-last-expression :prefixed t :inferior t)
+ ("\C-r" slime-eval-region :prefixed t :inferior t)
+ ("\C-\M-x" slime-eval-defun)
+ (":" slime-interactive-eval :prefixed t :sldb t)
+ ("\C-e" slime-interactive-eval :prefixed t :sldb t :inferior t)
+ ("\C-y" slime-call-defun :prefixed t)
+ ("E" slime-edit-value :prefixed t :sldb t :inferior t)
+ ("\C-z" slime-switch-to-output-buffer :prefixed t :sldb t)
+ ("\C-b" slime-interrupt :prefixed t :inferior t :sldb t)
+ ("\M-g" slime-quit :prefixed t :inferior t :sldb t)
+ ;; Documentation
+ (" " slime-space :inferior t)
+ ("\C-f" slime-describe-function :prefixed t :inferior t :sldb t)
+ ("\M-d" slime-disassemble-symbol :prefixed t :inferior t :sldb t)
+ ("\C-t" slime-toggle-trace-fdefinition :prefixed t :sldb t)
+ ("\C-u" slime-undefine-function :prefixed t)
+ ("\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)
+ ([(control meta ?\.)] slime-next-location :inferior t)
+ ("~" slime-sync-package-and-default-directory :prefixed t :inferior t)
+ ("\M-p" slime-repl-set-package :prefixed t :inferior t)
+ ;; Cross reference
+ ("<" slime-list-callers :prefixed t :inferior t :sldb t)
+ (">" slime-list-callees :prefixed t :inferior t :sldb t)
+ ;; "Other"
+ ("\I" slime-inspect :prefixed t :inferior t :sldb t)
+ ("\C-]" slime-close-all-parens-in-sexp :prefixed t :inferior t :sldb t)
+ ("\C-xt" slime-list-threads :prefixed t :inferior t :sldb t)
+ ("\C-xc" slime-list-connections :prefixed t :inferior t :sldb t)
+ ;; ;; Shadow unwanted bindings from inf-lisp
+ ;; ("\C-a" slime-nop :prefixed t :inferior t :sldb t)
+ ;; ("\C-v" slime-nop :prefixed t :inferior t :sldb t)
+ ))
+
+(defun slime-nop ()
+ "The null command. Used to shadow currently-unused keybindings."
+ (interactive)
+ (call-interactively 'undefined))
+
+(defvar slime-doc-map (make-sparse-keymap)
+ "Keymap for documentation commands. Bound to a prefix key.")
+
+(defvar slime-doc-bindings
+ '((?a slime-apropos)
+ (?z slime-apropos-all)
+ (?p slime-apropos-package)
+ (?d slime-describe-symbol)
+ (?f slime-describe-function)
+ (?h slime-hyperspec-lookup)
+ (?~ common-lisp-hyperspec-format)))
+
+(defvar slime-who-map (make-sparse-keymap)
+ "Keymap for who-xref commands. Bound to a prefix key.")
+
+(defvar slime-who-bindings
+ '((?c slime-who-calls)
+ (?w slime-calls-who)
+ (?r slime-who-references)
+ (?b slime-who-binds)
+ (?s slime-who-sets)
+ (?m slime-who-macroexpands)
+ (?a slime-who-specializes)))
+
+;; Maybe a good idea, maybe not..
+(defvar slime-prefix-key "\C-c"
+ "The prefix key to use in SLIME keybinding sequences.")
+
+(defun* slime-define-key (key command &key prefixed inferior)
+ "Define a keybinding of KEY for COMMAND.
+If PREFIXED is non-nil, `slime-prefix-key' is prepended to KEY."
+ (when prefixed
+ (setq key (concat slime-prefix-key key)))
+ (define-key slime-mode-map key command))
+
+(defun slime-init-keymaps ()
+ "(Re)initialize the keymaps for `slime-mode'."
+ (interactive)
+ (loop for (key command . keys) in slime-keys
+ do (apply #'slime-define-key key command :allow-other-keys t keys))
+ ;; Documentation
+ (setq slime-doc-map (make-sparse-keymap))
+ (loop for (key command) in slime-doc-bindings
+ do (progn
+ ;; We bind both unmodified and with control.
+ (define-key slime-doc-map (vector key) command)
+ (unless (equal key ?h) ; But don't bind C-h
+ (let ((modified (slime-control-modified-char key)))
+ (define-key slime-doc-map (vector modified) command)))))
+ ;; C-c C-d is the prefix for the doc map.
+ (slime-define-key "\C-d" slime-doc-map :prefixed t :inferior t)
+ ;; Who-xref
+ (setq slime-who-map (make-sparse-keymap))
+ (loop for (key command) in slime-who-bindings
+ do (progn
+ ;; We bind both unmodified and with control.
+ (define-key slime-who-map (vector key) command)
+ (let ((modified (slime-control-modified-char key)))
+ (define-key slime-who-map (vector modified) command))))
+ ;; C-c C-w is the prefix for the who-xref map.
+ (slime-define-key "\C-w" slime-who-map :prefixed t :inferior t))
+
+(defun slime-control-modified-char (char)
+ "Return the control-modified version of CHAR."
+ ;; Maybe better to just bitmask it?
+ (read (format "?\\C-%c" char)))
+
+(slime-init-keymaps)
+
+
+;;;; Setup initial `slime-mode' hooks
+
+(make-variable-buffer-local
+ (defvar slime-pre-command-actions nil
+ "List of functions to execute before the next Emacs command.
+This list of flushed between commands."))
+
+(defun slime-pre-command-hook ()
+ "Execute all functions in `slime-pre-command-actions', then NIL it."
+ (dolist (undo-fn slime-pre-command-actions)
+ (ignore-errors (funcall undo-fn)))
+ (setq slime-pre-command-actions nil))
+
+(defun slime-post-command-hook ()
+ (when (null pre-command-hook) ; sometimes this is lost
+ (add-hook 'pre-command-hook 'slime-pre-command-hook)))
+
+(defun slime-setup-command-hooks ()
+ "Setup a buffer-local `pre-command-hook' to call `slime-pre-command-hook'."
+ (add-local-hook 'pre-command-hook 'slime-pre-command-hook)
+ (add-local-hook 'post-command-hook 'slime-post-command-hook))
+
+
+;;;; Framework'ey bits
+;;;
+;;; This section contains some standard SLIME idioms: basic macros,
+;;; ways of showing messages to the user, etc. All the code in this
+;;; file should use these functions when applicable.
+;;;
+;;;;; Syntactic sugar
+
+(defmacro* when-let ((var value) &rest body)
+ "Evaluate VALUE, and if the result is non-nil bind it to VAR and
+evaluate BODY.
+
+\(fn (VAR VALUE) &rest BODY)"
+ `(let ((,var ,value))
+ (when ,var ,@body)))
+
+(put 'when-let 'lisp-indent-function 1)
+
+(defmacro with-lexical-bindings (variables &rest body)
+ "Execute BODY with VARIABLES in lexical scope."
+ `(lexical-let ,(mapcar (lambda (variable) (list variable variable))
+ variables)
+ ,@body))
+
+(put 'with-lexical-bindings 'lisp-indent-function 1)
+
+(defmacro destructure-case (value &rest patterns)
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (gensym "op-"))
+ (operands (gensym "rand-"))
+ (tmp (gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (case ,operator
+ ,@(mapcar (lambda (clause)
+ (if (eq (car clause) t)
+ `(t ,@(cdr clause))
+ (destructuring-bind ((op &rest rands) &rest body) clause
+ `(,op (destructuring-bind ,rands ,operands
+ . ,body)))))
+ patterns)
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "Elisp destructure-case failed: %S" ,tmp))))))))
+
+(put 'destructure-case 'lisp-indent-function 1)
+
+(defmacro slime-define-keys (keymap &rest key-command)
+ "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)."
+ `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c))
+ key-command)))
+
+(put 'slime-define-keys 'lisp-indent-function 1)
+
+(defmacro* with-struct ((conc-name &rest slots) struct &body body)
+ "Like with-slots but works only for structs.
+\(fn (CONC-NAME &rest SLOTS) STRUCT &body BODY)"
+ (flet ((reader (slot) (intern (concat (symbol-name conc-name)
+ (symbol-name slot)))))
+ (let ((struct-var (gensym "struct")))
+ `(let ((,struct-var ,struct))
+ (symbol-macrolet
+ ,(mapcar (lambda (slot)
+ (etypecase slot
+ (symbol `(,slot (,(reader slot) ,struct-var)))
+ (cons `(,(first slot) (,(reader (second slot))
+ ,struct-var)))))
+ slots)
+ . ,body)))))
+
+(put 'with-struct 'lisp-indent-function 2)
+
+;;;;; Very-commonly-used functions
+
+(defvar slime-message-function 'message)
+
+;; Interface
+(defun slime-message (format &rest args)
+ "Like `message' but with special support for multi-line messages.
+Single-line messages use the echo area."
+ (apply slime-message-function format args))
+
+(when (or (featurep 'xemacs)
+ (= emacs-major-version 20))
+ (setq slime-message-function 'slime-format-display-message))
+
+(defun slime-format-display-message (format &rest args)
+ (slime-display-message (apply #'format format args) "*SLIME Note*"))
+
+(defun slime-display-message (message buffer-name)
+ "Display MESSAGE in the echo area or in BUFFER-NAME.
+Use the echo area if MESSAGE needs only a single line. If the MESSAGE
+requires more than one line display it in BUFFER-NAME and add a hook
+to `slime-pre-command-actions' to remove the window before the next
+command."
+ (when (get-buffer-window buffer-name) (delete-windows-on buffer-name))
+ (cond ((or (string-match "\n" message)
+ (> (length message) (1- (frame-width))))
+ (lexical-let ((buffer (get-buffer-create buffer-name)))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (insert message)
+ (goto-char (point-min))
+ (let ((win (slime-create-message-window)))
+ (set-window-buffer win (current-buffer))
+ (shrink-window-if-larger-than-buffer
+ (display-buffer (current-buffer)))))
+ (push (lambda () (delete-windows-on buffer) (bury-buffer buffer))
+ slime-pre-command-actions)))
+ (t (message "%s" message))))
+
+(defun slime-create-message-window ()
+ "Create a window at the bottom of the frame, above the minibuffer."
+ (let ((previous (previous-window (minibuffer-window))))
+ (when (<= (window-height previous) (* 2 window-min-height))
+ (save-selected-window
+ (select-window previous)
+ (enlarge-window (- (1+ (* 2 window-min-height))
+ (window-height previous)))))
+ (split-window previous)))
+
+(defvar slime-background-message-function 'slime-display-oneliner)
+
+;; Interface
+(defun slime-background-message (format-string &rest format-args)
+ "Display a message in passing.
+This is like `slime-message', but less distracting because it
+will never pop up a buffer or display multi-line messages.
+It should be used for \"background\" messages such as argument lists."
+ (apply slime-background-message-function format-string format-args))
+
+(defun slime-display-oneliner (format-string &rest format-args)
+ (let* ((msg (apply #'format format-string format-args)))
+ (unless (minibuffer-window-active-p (minibuffer-window))
+ (message "%s" (slime-oneliner msg)))))
+
+(defun slime-oneliner (string)
+ "Return STRING truncated to fit in a single echo-area line."
+ (substring string 0 (min (length string)
+ (or (position ?\n string) most-positive-fixnum)
+ (1- (frame-width)))))
+
+;; Interface
+(defun slime-set-truncate-lines ()
+ "Apply `slime-truncate-lines' to the current buffer."
+ (when slime-truncate-lines
+ (set (make-local-variable 'truncate-lines) t)))
+
+;; Interface
+(defun slime-read-package-name (prompt &optional initial-value)
+ "Read a package name from the minibuffer, prompting with PROMPT."
+ (let ((completion-ignore-case t))
+ (completing-read prompt (slime-bogus-completion-alist
+ (slime-eval
+ `(swank:list-all-package-names t)))
+ nil t initial-value)))
+
+;; Interface
+(defun slime-read-symbol-name (prompt &optional query)
+ "Either read a symbol name or choose the one at point.
+The user is prompted if a prefix argument is in effect, if there is no
+symbol at point, or if QUERY is non-nil.
+
+This function avoids mistaking the REPL prompt for a symbol."
+ (cond ((or current-prefix-arg query (not (slime-symbol-name-at-point)))
+ (slime-read-from-minibuffer prompt (slime-symbol-name-at-point)))
+ (t (slime-symbol-name-at-point))))
+
+;; Interface
+(defmacro slime-propertize-region (props &rest body)
+ "Execute BODY and add PROPS to all the text it inserts.
+More precisely, PROPS are added to the region between the point's
+positions before and after executing BODY."
+ (let ((start (gensym)))
+ `(let ((,start (point)))
+ (prog1 (progn ,@body)
+ (add-text-properties ,start (point) ,props)))))
+
+(put 'slime-propertize-region 'lisp-indent-function 1)
+
+;; Interface
+(defsubst slime-insert-propertized (props &rest args)
+ "Insert all ARGS and then add text-PROPS to the inserted text."
+ (slime-propertize-region props (apply #'insert args)))
+
+(defmacro slime-with-rigid-indentation (level &rest body)
+ "Execute BODY and then rigidly indent its text insertions.
+Assumes all insertions are made at point."
+ (let ((start (gensym)) (l (gensym)))
+ `(let ((,start (point)) (,l ,(or level '(current-column))))
+ (prog1 (progn ,@body)
+ (slime-indent-rigidly ,start (point) ,l)))))
+
+(put 'slime-with-rigid-indentation 'lisp-indent-function 1)
+
+(defun slime-indent-rigidly (start end column)
+ ;; Similar to `indent-rigidly' but doesn't inherit text props.
+ (save-excursion
+ (goto-char end)
+ (beginning-of-line)
+ (while (and (<= start (point))
+ (progn
+ (save-excursion (insert-char ?\ column))
+ (zerop (forward-line -1)))))))
+
+(defun slime-insert-indented (&rest strings)
+ "Insert all arguments rigidly indented."
+ (slime-with-rigid-indentation nil
+ (apply #'insert strings)))
+
+(defun slime-curry (fun &rest args)
+ `(lambda (&rest more) (apply ',fun (append ',args more))))
+
+(defun slime-rcurry (fun &rest args)
+ `(lambda (&rest more) (apply ',fun (append more ',args))))
+
+;;;;; Snapshots of current Emacs state
+
+;;; Window configurations do not save (and hence not restore)
+;;; any narrowing that could be applied to a buffer.
+;;;
+;;; For this purpose, we introduce a superset of a window
+;;; configuration that does include the necessary information to
+;;; properly restore narrowing.
+;;;
+;;; We call this superset an Emacs Snapshot.
+
+(defstruct (slime-narrowing-configuration
+ (:conc-name slime-narrowing-configuration.))
+ narrowedp beg end)
+
+(defstruct (slime-emacs-snapshot (:conc-name slime-emacs-snapshot.))
+ window-configuration narrowing-configuration)
+
+(defun slime-current-narrowing-configuration (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (make-slime-narrowing-configuration :narrowedp (slime-buffer-narrowed-p)
+ :beg (point-min-marker)
+ :end (point-max-marker))))
+
+(defun slime-set-narrowing-configuration (narrowing-cfg)
+ (when (slime-narrowing-configuration.narrowedp narrowing-cfg)
+ (narrow-to-region (slime-narrowing-configuration.beg narrowing-cfg)
+ (slime-narrowing-configuration.end narrowing-cfg))))
+
+(defun slime-current-emacs-snapshot (&optional frame)
+ "Returns a snapshot of the current state of FRAME, or the
+currently active frame if FRAME is not given respectively."
+ (with-current-buffer
+ (if frame
+ (window-buffer (frame-selected-window (selected-frame)))
+ (current-buffer))
+ (make-slime-emacs-snapshot
+ :window-configuration (current-window-configuration frame)
+ :narrowing-configuration (slime-current-narrowing-configuration))))
+
+(defun slime-set-emacs-snapshot (snapshot)
+ "Restores the state of Emacs according to the information saved
+in SNAPSHOT."
+ (let ((window-cfg (slime-emacs-snapshot.window-configuration snapshot))
+ (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot)))
+ (set-window-configuration window-cfg) ; restores previously current buffer.
+ (slime-set-narrowing-configuration narrowing-cfg)))
+
+(defun slime-current-emacs-snapshot-fingerprint (&optional frame)
+ "Return a fingerprint of the current emacs snapshot.
+Fingerprints are `equalp' if and only if they represent window
+configurations that are very similar (same windows and buffers.)
+
+Unlike real window-configuration objects, fingerprints are not
+sensitive to the point moving and they can't be restored."
+ (mapcar (lambda (window) (list window (window-buffer window)))
+ (slime-frame-windows frame)))
+
+(defun slime-frame-windows (&optional frame)
+ "Return the list of windows in FRAME."
+ (loop with last-window = (previous-window (frame-first-window frame))
+ for window = (frame-first-window frame) then (next-window window)
+ collect window
+ until (eq window last-window)))
+
+
+(defmacro save-restriction-if-possible (&rest body)
+ "Very similiarly to `save-restriction'. The only difference is
+that it's not enforcing the restriction as strictly: It's only
+enforced if `point' was not moved outside of the restriction
+after executing BODY.
+
+Example:
+
+ (progn (goto-line 1000)
+ (narrow-to-page)
+ (save-restriction-if-possible (widen) (goto-line 999)))
+
+ In this case, the buffer is narrowed to the current page, and
+ point is on line 999.
+
+ (progn (goto-char 1000)
+ (narrow-to-page)
+ (save-restriction-if-possible (widen) (goto-line 1)))
+
+ Whereas in this case, the buffer is widened and point is on
+ line 1."
+ (let ((gcfg (gensym "NARROWING-CFG+"))
+ (gbeg (gensym "OLDBEG+"))
+ (gend (gensym "OLDEND+")))
+ `(let ((,gcfg (slime-current-narrowing-configuration)))
+ (unwind-protect (progn ,@body)
+ (let ((,gbeg (slime-narrowing-configuration.beg ,gcfg))
+ (,gend (slime-narrowing-configuration.end ,gcfg)))
+ (when (and (>= (point) ,gbeg) (<= (point) ,gend))
+ (slime-set-narrowing-configuration ,gcfg)))))))
+
+(put 'save-restriction-if-possible 'lisp-indent-function 0)
+
+;;;;; Temporary popup buffers
+
+(make-variable-buffer-local
+ (defvar slime-temp-buffer-saved-emacs-snapshot nil
+ "The snapshot of the current state in Emacs before the temp-buffer
+was displayed, so that this state can be restored later on.
+Buffer local in temp-buffers."))
+
+(make-variable-buffer-local
+ (defvar slime-temp-buffer-saved-fingerprint nil
+ "The emacs snapshot \"fingerprint\" after displaying the buffer."))
+
+;; Interface
+(defun* slime-get-temp-buffer-create (name &key mode noselectp reusep
+ emacs-snapshot)
+ "Return a fresh temporary buffer called NAME in MODE.
+The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing
+`q' in the buffer will restore the window configuration to the way it
+is when the buffer was created, i.e. when this function was called.
+
+If NOSELECTP is true, then the buffer is shown by `display-buffer',
+otherwise it is shown and selected by `pop-to-buffer'.
+
+If REUSEP is true and a buffer does already exist with name NAME,
+then the buffer will be reused instead of being killed.
+
+If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous
+state of Emacs after closing the temporary buffer. Otherwise, the
+current state will be saved and later restored.
+"
+ (let ((snapshot (or emacs-snapshot (slime-current-emacs-snapshot)))
+ (buffer (get-buffer name)))
+ (when (and buffer (not reusep))
+ (kill-buffer name)
+ (setq buffer nil))
+ (with-current-buffer (or buffer (get-buffer-create name))
+ (when mode
+ (let ((original-configuration slime-temp-buffer-saved-emacs-snapshot)
+ (original-fingerprint slime-temp-buffer-saved-fingerprint))
+ (funcall mode)
+ (setq slime-temp-buffer-saved-emacs-snapshot original-configuration)
+ (setq slime-temp-buffer-saved-fingerprint original-fingerprint)))
+ (slime-temp-buffer-mode 1)
+ (let ((window (get-buffer-window (current-buffer))))
+ (if window
+ (unless noselectp
+ (select-window window))
+ (progn
+ (if noselectp
+ (display-buffer (current-buffer) t)
+ (pop-to-buffer (current-buffer))
+ (selected-window))
+ (setq slime-temp-buffer-saved-emacs-snapshot snapshot)
+ (setq slime-temp-buffer-saved-fingerprint
+ (slime-current-emacs-snapshot-fingerprint)))))
+ (current-buffer))))
+
+;; Interface
+(defmacro* slime-with-output-to-temp-buffer ((name &key mode reusep)
+ package &rest body)
+ "Similar to `with-output-to-temp-buffer'.
+Also saves the current state of Emacs (window configuration &c),
+and inherits the current `slime-connection' in a buffer-local
+variable. Cf. `slime-get-temp-buffer-create'"
+ `(let ((connection (slime-connection))
+ (standard-output (slime-get-temp-buffer-create ,name :mode ',mode
+ :reusep ,reusep)))
+ (prog1 (with-current-buffer standard-output
+ ;; set explicitely to NIL in case the buffer got reused. (REUSEP)
+ (let ((buffer-read-only nil)) ,@body))
+ (with-current-buffer standard-output
+ (setq slime-buffer-connection connection)
+ (setq slime-buffer-package ,package)
+ (goto-char (point-min))
+ (slime-mode 1)
+ (set-syntax-table lisp-mode-syntax-table)
+ (setq buffer-read-only t)))))
+
+(put 'slime-with-output-to-temp-buffer 'lisp-indent-function 2)
+
+(define-minor-mode slime-temp-buffer-mode
+ "Mode for displaying read only stuff"
+ nil
+ " temp"
+ '(("q" . slime-temp-buffer-quit)))
+
+;; Interface
+(defun slime-temp-buffer-quit (&optional kill-buffer-p)
+ "Get rid of the current (temp) buffer without asking. Restore the
+window configuration unless it was changed since we last activated the buffer."
+ (interactive)
+ (let ((snapshot slime-temp-buffer-saved-emacs-snapshot)
+ (temp-buffer (current-buffer)))
+ (setq slime-temp-buffer-saved-emacs-snapshot nil)
+ (if (and snapshot (equalp (slime-current-emacs-snapshot-fingerprint)
+ slime-temp-buffer-saved-fingerprint))
+ (slime-set-emacs-snapshot snapshot)
+ (bury-buffer))
+ (when kill-buffer-p
+ (kill-buffer temp-buffer))))
+
+;;;;; Filename translation
+;;;
+;;; Filenames passed between Emacs and Lisp should be translated using
+;;; these functions. This way users who run Emacs and Lisp on separate
+;;; machines have a chance to integrate file operations somehow.
+
+(defun slime-to-lisp-filename (filename)
+ "Translate the string FILENAME to a Lisp filename.
+See `slime-filename-translations'."
+ (funcall (first (slime-find-filename-translators (slime-machine-instance)))
+ (expand-file-name filename)))
+
+(defun slime-from-lisp-filename (filename)
+ "Translate the Lisp filename FILENAME to an Emacs filename.
+See `slime-filename-translations'."
+ (funcall (second (slime-find-filename-translators (slime-machine-instance)))
+ filename))
+
+(defun slime-find-filename-translators (hostname)
+ (cond ((and hostname slime-filename-translations)
+ (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname))
+ slime-filename-translations))
+ (error "No filename-translations for hostname: %s" hostname)))
+ (t (list #'identity #'identity))))
+
+
+;;;; Starting SLIME
+;;;
+;;; This section covers starting an inferior-lisp, compiling and
+;;; starting the server, initiating a network connection.
+
+;;;;; Entry points
+
+;; We no longer load inf-lisp, but we use this variable for backward
+;; compatibility.
+(defvar inferior-lisp-program "lisp"
+ "*Program name for invoking an inferior Lisp with for Inferior Lisp mode.")
+
+(defvar slime-lisp-implementations nil
+ "*A list of known Lisp implementations.
+The list should have the form:
+ ((NAME (PROGRAM PROGRAM-ARGS...) &key INIT CODING-SYSTEM) ...)
+
+NAME is a symbol for the implementation.
+PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process.
+INIT is a function that should return a string to load and start
+ Swank. The function will be called with the PORT-FILENAME and ENCODING as
+ arguments. INIT defaults to `slime-init-command'.
+CODING-SYSTEM a symbol for the coding system. The default is
+ slime-net-coding-system
+
+Here's an example:
+ ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command)
+ (acl (\"acl7\") :coding-system emacs-mule))")
+
+(defvar slime-default-lisp nil
+ "*The name of the default Lisp implementation.
+See `slime-lisp-implementations'")
+
+(defvar slime-lisp-host "127.0.0.1"
+ "The default hostname (or IP address) to connect to.")
+
+;; dummy definitions for the compiler
+(defvar slime-net-coding-system)
+(defvar slime-net-processes)
+(defvar slime-default-connection)
+
+(defun slime (&optional command coding-system)
+ "Start an inferior^_superior Lisp and connect to its Swank server."
+ (interactive)
+ (let ((inferior-lisp-program (or command inferior-lisp-program))
+ (slime-net-coding-system (or coding-system slime-net-coding-system)))
+ (slime-start* (slime-read-interactive-args))))
+
+(defvar slime-inferior-lisp-program-history '()
+ "History list of command strings. Used by `slime'.")
+
+(defun slime-read-interactive-args ()
+ "Return the list of args which should be passed to `slime-start'.
+
+The rules for selecting the arguments are rather complicated:
+
+- In the most common case, i.e. if there's no prefix-arg in
+ effect and if `slime-lisp-implementations' is nil, use
+ `inferior-lisp-program' as fallback.
+
+- If the table `slime-lisp-implementations' is non-nil use the
+ implementation with name `slime-default-lisp' or if that's nil
+ the first entry in the table.
+
+- If the prefix-arg is `-', prompt for one of the registered
+ lisps.
+
+- If the prefix-arg is positive, read the command to start the
+ process."
+ (let ((table slime-lisp-implementations))
+ (cond ((not current-prefix-arg) (slime-lisp-options))
+ ((eq current-prefix-arg '-)
+ (let ((key (completing-read
+ "Lisp name: " (mapcar (lambda (x)
+ (list (symbol-name (car x))))
+ table)
+ nil t)))
+ (slime-lookup-lisp-implementation table (intern key))))
+ (t
+ (destructuring-bind (program &rest program-args)
+ (split-string (read-string
+ "Run lisp: " inferior-lisp-program
+ 'slime-inferior-lisp-program-history))
+ (let ((coding-system
+ (if (eq 16 (prefix-numeric-value current-prefix-arg))
+ (read-coding-system "set slime-coding-system: "
+ slime-net-coding-system)
+ slime-net-coding-system)))
+ (list :program program :program-args program-args
+ :coding-system coding-system)))))))
+
+(defun slime-lisp-options (&optional name)
+ (let ((table slime-lisp-implementations))
+ (assert (or (not name) table))
+ (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations
+ (or name slime-default-lisp
+ (car (car table)))))
+ (t (destructuring-bind (program &rest args)
+ (split-string inferior-lisp-program)
+ (list :program program :program-args args))))))
+
+(defun slime-lookup-lisp-implementation (table name)
+ (destructuring-bind (name (prog &rest args) &rest keys) (assoc name table)
+ (list* :name name :program prog :program-args args keys)))
+
+(defun* slime-start (&key (program inferior-lisp-program) program-args
+ directory
+ (coding-system slime-net-coding-system)
+ (init 'slime-init-command)
+ name
+ (buffer "*inferior-lisp*")
+ init-function)
+ (let ((args (list :program program :program-args program-args :buffer buffer
+ :coding-system coding-system :init init :name name
+ :init-function init-function)))
+ (slime-check-coding-system coding-system)
+ (when (slime-bytecode-stale-p)
+ (slime-urge-bytecode-recompile))
+ (let ((proc (slime-maybe-start-lisp program program-args
+ directory buffer)))
+ (slime-inferior-connect proc args)
+ (pop-to-buffer (process-buffer proc)))))
+
+(defun slime-start* (options)
+ (apply #'slime-start options))
+
+(defun slime-connect (host port &optional coding-system)
+ "Connect to a running Swank server."
+ (interactive (list (read-from-minibuffer "Host: " slime-lisp-host)
+ (read-from-minibuffer "Port: " "4005" nil t)))
+ (when (and (interactive-p) slime-net-processes
+ (y-or-n-p "Close old connections first? "))
+ (slime-disconnect))
+ (message "Connecting to Swank on port %S.." port)
+ (let ((coding-system (or coding-system slime-net-coding-system)))
+ (slime-check-coding-system coding-system)
+ (message "Connecting to Swank on port %S.." port)
+ (let* ((process (slime-net-connect host port coding-system))
+ (slime-dispatching-connection process))
+ (slime-setup-connection process))))
+
+(defun slime-start-and-load (filename &optional package)
+ "Start Slime, if needed, load the current file and set the package."
+ (interactive (list (expand-file-name (buffer-file-name))
+ (slime-find-buffer-package)))
+ (cond ((slime-connected-p)
+ (slime-load-file-set-package filename package))
+ (t
+ (slime-start-and-init (slime-lisp-options)
+ (slime-curry #'slime-start-and-load
+ filename package)))))
+
+(defun slime-start-and-init (options fun)
+ (let* ((rest (plist-get options :init-function))
+ (init (cond (rest `(lambda () (funcall ',rest) (funcall ',fun)))
+ (t fun))))
+ (slime-start* (plist-put (copy-list options) :init-function init))))
+
+(defun slime-load-file-set-package (filename package)
+ (let ((filename (slime-to-lisp-filename filename)))
+ (slime-eval-async `(swank:load-file-set-package ,filename ,package)
+ (lambda (package)
+ (when package
+ (slime-repl-set-package (second package)))))))
+
+;;;;; Start inferior lisp
+;;;
+;;; Here is the protocol for starting SLIME:
+;;;
+;;; 0. Emacs recompiles/reloads slime.elc if it exists and is stale.
+;;; 1. Emacs starts an inferior Lisp process.
+;;; 2. Emacs tells Lisp (via stdio) to load and start Swank.
+;;; 3. Lisp recompiles the Swank if needed.
+;;; 4. Lisp starts the Swank server and writes its TCP port to a temp file.
+;;; 5. Emacs reads the temp file to get the port and then connects.
+;;; 6. Emacs prints a message of warm encouragement for the hacking ahead.
+;;;
+;;; Between steps 2-5 Emacs polls for the creation of the temp file so
+;;; that it can make the connection. This polling may continue for a
+;;; fair while if Swank needs recompilation.
+
+(defvar slime-connect-retry-timer nil
+ "Timer object while waiting for an inferior-lisp to start.")
+
+;;; Recompiling bytecode:
+
+(defun slime-bytecode-stale-p ()
+ "Return true if slime.elc is older than slime.el."
+ (when-let (libfile (locate-library "slime"))
+ (let* ((basename (file-name-sans-extension libfile))
+ (sourcefile (concat basename ".el"))
+ (bytefile (concat basename ".elc")))
+ (and (file-exists-p bytefile)
+ (file-newer-than-file-p sourcefile bytefile)))))
+
+(defun slime-recompile-bytecode ()
+ "Recompile and reload slime.
+Warning: don't use this in XEmacs, it seems to crash it!"
+ (interactive)
+ (let ((sourcefile (concat (file-name-sans-extension (locate-library "slime"))
+ ".el")))
+ (byte-compile-file sourcefile t)))
+
+(defun slime-urge-bytecode-recompile ()
+ "Urge the user to recompile slime.elc.
+Return true if we have been given permission to continue."
+ (cond ((featurep 'xemacs)
+ ;; My XEmacs crashes and burns if I recompile/reload an elisp
+ ;; file from itself. So they have to do it themself.
+ (or (y-or-n-p "slime.elc is older than source. Continue? ")
+ (signal 'quit nil)))
+ ((y-or-n-p "slime.elc is older than source. Recompile first? ")
+ (slime-recompile-bytecode))
+ (t)))
+
+(defun slime-abort-connection ()
+ "Abort connection the current connection attempt."
+ (interactive)
+ (cond (slime-connect-retry-timer
+ (slime-cancel-connect-retry-timer)
+ (message "Cancelled connection attempt."))
+ (t (error "Not connecting"))))
+
+;;; Starting the inferior Lisp and loading Swank:
+
+(defun slime-maybe-start-lisp (program program-args directory buffer)
+ "Return a new or existing inferior lisp process."
+ (cond ((not (comint-check-proc buffer))
+ (slime-start-lisp program program-args directory buffer))
+ ((slime-reinitialize-inferior-lisp-p program program-args buffer)
+ (when-let (conn (find (get-buffer-process buffer) slime-net-processes
+ :key #'slime-inferior-process))
+ (slime-net-close conn))
+ (get-buffer-process buffer))
+ (t (slime-start-lisp program program-args
+ directory
+ (generate-new-buffer-name buffer)))))
+
+(defun slime-reinitialize-inferior-lisp-p (program program-args buffer)
+ (let ((args (slime-inferior-lisp-args (get-buffer-process buffer))))
+ (and (equal (plist-get args :program) program)
+ (equal (plist-get args :program-args) program-args)
+ (not (y-or-n-p "Create an additional *inferior-lisp*? ")))))
+
+(defun slime-start-lisp (program program-args directory buffer)
+ "Does the same as `inferior-lisp' but less ugly.
+Return the created process."
+ (with-current-buffer (get-buffer-create buffer)
+ (when directory
+ (cd (expand-file-name directory)))
+ (comint-mode)
+ (comint-exec (current-buffer) "inferior-lisp" program nil program-args)
+ (lisp-mode-variables t)
+ (let ((proc (get-buffer-process (current-buffer))))
+ (slime-set-query-on-exit-flag proc)
+ proc)))
+
+(defun slime-inferior-connect (process args)
+ "Start a Swank server in the inferior Lisp and connect."
+ (slime-delete-swank-port-file 'quiet)
+ (slime-start-swank-server process args)
+ (slime-read-port-and-connect process nil))
+
+(defvar slime-inferior-lisp-args nil
+ "A buffer local variable in the inferior proccess.")
+
+(defun slime-start-swank-server (process args)
+ "Start a Swank server on the inferior lisp."
+ (destructuring-bind (&key coding-system init &allow-other-keys) args
+ (with-current-buffer (process-buffer process)
+ (make-local-variable 'slime-inferior-lisp-args)
+ (setq slime-inferior-lisp-args args)
+ (let ((str (funcall init (slime-swank-port-file) coding-system)))
+ (goto-char (process-mark process))
+ (insert-before-markers str)
+ (process-send-string process str)))))
+
+(defun slime-inferior-lisp-args (process)
+ (with-current-buffer (process-buffer process)
+ slime-inferior-lisp-args))
+
+;; XXX load-server & start-server used to be separated. maybe that was better.
+(defun slime-init-command (port-filename coding-system)
+ "Return a string to initialize Lisp."
+ (let ((loader (if (file-name-absolute-p slime-backend)
+ slime-backend
+ (concat slime-path slime-backend)))
+ (encoding (slime-coding-system-cl-name coding-system)))
+ ;; Return a single form to avoid problems with buffered input.
+ (format "%S\n\n"
+ `(progn
+ (load ,(expand-file-name loader) :verbose t)
+ (funcall (read-from-string "swank:start-server")
+ ,port-filename
+ :coding-system ,encoding)))))
+
+(defun slime-swank-port-file ()
+ "Filename where the SWANK server writes its TCP port number."
+ (concat (file-name-as-directory
+ (cond ((fboundp 'temp-directory) (temp-directory))
+ ((boundp 'temporary-file-directory) temporary-file-directory)
+ (t "/tmp/")))
+ (format "slime.%S" (emacs-pid))))
+
+(defun slime-delete-swank-port-file (&optional quiet)
+ (condition-case data
+ (delete-file (slime-swank-port-file))
+ (error
+ (ecase quiet
+ ((nil) (signal (car data) (cdr data)))
+ (quiet)
+ (message (message "Unable to delete swank port file %S"
+ (slime-swank-port-file)))))))
+
+(defun slime-read-port-and-connect (inferior-process retries)
+ (slime-cancel-connect-retry-timer)
+ (slime-attempt-connection inferior-process retries 1))
+
+(defun slime-attempt-connection (process retries attempt)
+ ;; A small one-state machine to attempt a connection with
+ ;; timer-based retries.
+ (let ((file (slime-swank-port-file)))
+ (unless (active-minibuffer-window)
+ (message "Polling %S.. (Abort with `M-x slime-abort-connection'.)" file))
+ (unless (slime-connected-p)
+ (slime-set-state (format "[polling:%S]" attempt)))
+ (slime-cancel-connect-retry-timer)
+ (cond ((and (file-exists-p file)
+ (> (nth 7 (file-attributes file)) 0)) ; file size
+ (let ((port (slime-read-swank-port))
+ (args (slime-inferior-lisp-args process)))
+ (slime-delete-swank-port-file 'message)
+ (let ((c (slime-connect slime-lisp-host port
+ (plist-get args :coding-system))))
+ (slime-set-inferior-process c process))))
+ ((and retries (zerop retries))
+ (message "Failed to connect to Swank."))
+ (t
+ (when (and (file-exists-p file)
+ (zerop (nth 7 (file-attributes file))))
+ (message "(Zero length port file)")
+ ;; the file may be in the filesystem but not yet written
+ (unless retries (setq retries 3)))
+ (setq slime-connect-retry-timer
+ (run-with-timer 0.3 nil
+ #'slime-timer-call #'slime-attempt-connection
+ process (and retries (1- retries))
+ (1+ attempt)))))))
+
+(defun slime-timer-call (fun &rest args)
+ "Call function FUN with ARGS, reporting all errors.
+
+The default condition handler for timer functions (see
+`timer-event-handler') ignores errors."
+ (condition-case data
+ (apply fun args)
+ (error (debug nil (list "Error in timer" fun args data)))))
+
+(defun slime-cancel-connect-retry-timer ()
+ (when slime-connect-retry-timer
+ (cancel-timer slime-connect-retry-timer)
+ (setq slime-connect-retry-timer nil)))
+
+(defun slime-read-swank-port ()
+ "Read the Swank server port number from the `slime-swank-port-file'."
+ (save-excursion
+ (with-temp-buffer
+ (insert-file-contents (slime-swank-port-file))
+ (goto-char (point-min))
+ (let ((port (read (current-buffer))))
+ (assert (integerp port))
+ port))))
+
+(defun slime-hide-inferior-lisp-buffer ()
+ "Display the REPL buffer instead of the *inferior-lisp* buffer."
+ (let* ((buffer (if (slime-process)
+ (process-buffer (slime-process))))
+ (window (if buffer (get-buffer-window buffer)))
+ (repl-buffer (slime-output-buffer t))
+ (repl-window (get-buffer-window repl-buffer)))
+ (when buffer
+ (bury-buffer buffer))
+ (cond (repl-window
+ (when window
+ (delete-window window)))
+ (window
+ (set-window-buffer window repl-buffer))
+ (t
+ (pop-to-buffer repl-buffer)
+ (goto-char (point-max))))))
+
+;;; Words of encouragement
+
+(defun slime-user-first-name ()
+ (let ((name (if (string= (user-full-name) "")
+ (user-login-name)
+ (user-full-name))))
+ (string-match "^[^ ]*" name)
+ (capitalize (match-string 0 name))))
+
+(defvar slime-words-of-encouragement
+ `("Let the hacking commence!"
+ "Hacks and glory await!"
+ "Hack and be merry!"
+ "Your hacking starts... NOW!"
+ "May the source be with you!"
+ "Take this REPL, brother, and may it serve you well."
+ "Lemonodor-fame is but a hack away!"
+ ,(format "%s, this could be the start of a beautiful program."
+ (slime-user-first-name)))
+ "Scientifically-proven optimal words of hackerish encouragement.")
+
+(defun slime-random-words-of-encouragement ()
+ "Return a string of hackerish encouragement."
+ (eval (nth (random (length slime-words-of-encouragement))
+ slime-words-of-encouragement)))
+
+
+;;;; Networking
+;;;
+;;; This section covers the low-level networking: establishing
+;;; connections and encoding/decoding protocol messages.
+;;;
+;;; Each SLIME protocol message beings with a 3-byte length header
+;;; followed by an S-expression as text. The sexp must be readable
+;;; both by Emacs and by Common Lisp, so if it contains any embedded
+;;; code fragments they should be sent as strings.
+;;;
+;;; The set of meaningful protocol messages are not specified
+;;; here. They are defined elsewhere by the event-dispatching
+;;; functions in this file and in swank.lisp.
+
+(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-secret ()
+ "Finds the magic secret from the user's home directory.
+Returns nil if the file doesn't exist or is empty; otherwise the first
+line of the file."
+ (condition-case err
+ (with-temp-buffer
+ (insert-file-contents "~/.slime-secret")
+ (goto-char (point-min))
+ (buffer-substring (point-min) (line-end-position)))
+ (file-error nil)))
+
+;;; Interface
+(defun slime-net-connect (host port coding-system)
+ "Establish a connection with a CL."
+ (let* ((inhibit-quit nil)
+ (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)
+ (slime-set-query-on-exit-flag proc)
+ (when (fboundp 'set-process-coding-system)
+ (slime-check-coding-system coding-system)
+ (set-process-coding-system proc coding-system coding-system))
+ (when-let (secret (slime-secret))
+ (slime-net-send secret proc))
+ proc))
+
+(defun slime-make-net-buffer (name)
+ "Make a buffer suitable for a network process."
+ (let ((buffer (generate-new-buffer name)))
+ (with-current-buffer buffer
+ (buffer-disable-undo))
+ buffer))
+
+(defun slime-set-query-on-exit-flag (process)
+ "Set PROCESS's query-on-exit-flag to `slime-kill-without-query-p'."
+ (when slime-kill-without-query-p
+ ;; avoid byte-compiler warnings
+ (let ((fun (if (fboundp 'set-process-query-on-exit-flag)
+ 'set-process-query-on-exit-flag
+ 'process-kill-without-query)))
+ (funcall fun process nil))))
+
+;;;;; Coding system madness
+
+(defvar slime-net-valid-coding-systems
+ '((iso-latin-1-unix nil "iso-latin-1-unix")
+ (iso-8859-1-unix nil "iso-latin-1-unix")
+ (binary nil "iso-latin-1-unix")
+ (utf-8-unix t "utf-8-unix")
+ (emacs-mule-unix t "emacs-mule-unix")
+ (euc-jp-unix t "euc-jp-unix"))
+ "A list of valid coding systems.
+Each element is of the form: (NAME MULTIBYTEP CL-NAME)")
+
+(defun slime-find-coding-system (name)
+ "Return the coding system for the symbol NAME.
+The result is either an element in `slime-net-valid-coding-systems'
+of nil."
+ (let* ((probe (assq name slime-net-valid-coding-systems)))
+ (if (and probe (if (fboundp 'check-coding-system)
+ (ignore-errors (check-coding-system (car probe)))
+ (eq (car probe) 'binary)))
+ probe)))
+
+(defvar slime-net-coding-system
+ (find-if 'slime-find-coding-system
+ '(iso-latin-1-unix iso-8859-1-unix binary))
+ "*Coding system used for network connections.
+See also `slime-net-valid-coding-systems'.")
+
+(defun slime-check-coding-system (coding-system)
+ "Signal an error if CODING-SYSTEM isn't a valid coding system."
+ (interactive)
+ (let ((props (slime-find-coding-system coding-system)))
+ (unless props
+ (error "Invalid slime-net-coding-system: %s. %s"
+ coding-system (mapcar #'car slime-net-valid-coding-systems)))
+ (when (and (second props) (boundp 'default-enable-multibyte-characters))
+ (assert default-enable-multibyte-characters))
+ t))
+
+(defcustom slime-repl-history-file-coding-system
+ (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix)
+ (t slime-net-coding-system))
+ "*The coding system for the history file."
+ :type 'symbol
+ :group 'slime-repl)
+
+(defun slime-coding-system-mulibyte-p (coding-system)
+ (second (slime-find-coding-system coding-system)))
+
+(defun slime-coding-system-cl-name (coding-system)
+ (third (slime-find-coding-system coding-system)))
+
+;;; Interface
+(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 (concat (slime-prin1-to-string sexp) "\n"))
+ (string (concat (slime-net-encode-length (length msg)) msg))
+ (coding-system (cdr (process-coding-system proc))))
+ (slime-log-event sexp)
+ (cond ((slime-safe-encoding-p coding-system string)
+ (process-send-string proc string))
+ (t (error "Coding system %s not suitable for %S"
+ coding-system string)))))
+
+(defun slime-safe-encoding-p (coding-system string)
+ "Return true iff CODING-SYSTEM can safely encode STRING."
+ (if (featurep 'xemacs)
+ ;; FIXME: XEmacs encodes non-encodeable chars as ?~ automatically
+ t
+ (or (let ((candidates (find-coding-systems-string string))
+ (base (coding-system-base coding-system)))
+ (or (equal candidates '(undecided))
+ (memq base candidates)))
+ (and (not (multibyte-string-p string))
+ (not (slime-coding-system-mulibyte-p coding-system))))))
+
+(defun slime-net-close (process &optional debug)
+ (setq slime-net-processes (remove process slime-net-processes))
+ (when (eq process slime-default-connection)
+ (setq slime-default-connection nil))
+ (cond (debug
+ (set-process-sentinel process 'ignore)
+ (set-process-filter process 'ignore)
+ (delete-process process))
+ (t
+ (run-hook-with-args 'slime-net-process-close-hooks process)
+ ;; killing the buffer also closes the socket
+ (kill-buffer (process-buffer process)))))
+
+(defun slime-net-sentinel (process message)
+ (message "Lisp connection closed unexpectedly: %s" message)
+ (slime-net-close process)
+ (slime-set-state "[not connected]" process))
+
+;;; Socket input is handled by `slime-net-filter', which decodes any
+;;; complete messages and hands them off to the event dispatcher.
+
+(defun slime-net-filter (process string)
+ "Accept output from the socket and process all complete messages."
+ (with-current-buffer (process-buffer process)
+ (goto-char (point-max))
+ (insert string))
+ (slime-process-available-input process))
+
+(defun slime-run-when-idle (function &rest args)
+ "Call FUNCTION as soon as Emacs is idle."
+ (apply #'run-at-time
+ (if (featurep 'xemacs) itimer-short-interval 0)
+ nil function args))
+
+(defun slime-process-available-input (process)
+ "Process all complete messages that have arrived from Lisp."
+ (with-current-buffer (process-buffer process)
+ (while (slime-net-have-input-p)
+ (let ((event (slime-net-read-or-lose process))
+ (ok nil))
+ (slime-log-event event)
+ (unwind-protect
+ (save-current-buffer
+ (slime-dispatch-event event process)
+ (setq ok t))
+ (unless ok
+ (slime-run-when-idle 'slime-process-available-input process)))))))
+
+(defun slime-net-have-input-p ()
+ "Return true if a complete message is available."
+ (goto-char (point-min))
+ (and (>= (buffer-size) 6)
+ (>= (- (buffer-size) 6) (slime-net-decode-length))))
+
+(defun slime-net-read-or-lose (process)
+ (condition-case error
+ (slime-net-read)
+ (error
+ (debug)
+ (slime-net-close process t)
+ (error "net-read error: %S" error))))
+
+(defun slime-net-read ()
+ "Read a message from the network buffer."
+ (goto-char (point-min))
+ (let* ((length (slime-net-decode-length))
+ (start (+ 6 (point)))
+ (end (+ start length)))
+ (assert (plusp length))
+ (let ((string (buffer-substring-no-properties start end)))
+ (prog1 (read string)
+ (delete-region (point-min) end)))))
+
+(defun slime-net-decode-length ()
+ "Read a 24-bit hex-encoded integer from buffer."
+ (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16))
+
+(defun slime-net-encode-length (n)
+ "Encode an integer into a 24-bit hex string."
+ (format "%06x" n))
+
+(defun slime-prin1-to-string (sexp)
+ "Like `prin1-to-string' but don't octal-escape non-ascii characters.
+This is more compatible with the CL reader."
+ (with-temp-buffer
+ (let ((print-escape-nonascii nil)
+ (print-escape-newlines nil))
+ (prin1 sexp (current-buffer))
+ (buffer-string))))
+
+
+;;;; Connections
+;;;
+;;; "Connections" are the high-level Emacs<->Lisp networking concept.
+;;;
+;;; Emacs has a connection to each Lisp process that it's interacting
+;;; with. Typically there would only be one, but a user can choose to
+;;; connect to many Lisps simultaneously.
+;;;
+;;; A connection consists of a control socket, optionally an extra
+;;; socket dedicated to receiving Lisp output (an optimization), and a
+;;; set of connection-local state variables.
+;;;
+;;; The state variables are stored as buffer-local variables in the
+;;; control socket's process-buffer and are used via accessor
+;;; functions. These variables include things like the *FEATURES* list
+;;; and Unix Pid of the Lisp process.
+;;;
+;;; One connection is "current" at any given time. This is:
+;;; `slime-dispatching-connection' if dynamically bound, or
+;;; `slime-buffer-connection' if this is set buffer-local, or
+;;; `slime-default-connection' otherwise.
+;;;
+;;; When you're invoking commands in your source files you'll be using
+;;; `slime-default-connection'. This connection can be interactively
+;;; reassigned via the connection-list buffer.
+;;;
+;;; When a command creates a new buffer it will set
+;;; `slime-buffer-connection' so that commands in the new buffer will
+;;; use the connection that the buffer originated from. For example,
+;;; the apropos command creates the *Apropos* buffer and any command
+;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the
+;;; apropos search. REPL buffers are similarly tied to their
+;;; respective connections.
+;;;
+;;; When Emacs is dispatching some network message that arrived from a
+;;; connection it will dynamically bind `slime-dispatching-connection'
+;;; so that the event will be processed in the context of that
+;;; connection.
+;;;
+;;; This is mostly transparent. The user should be aware that he can
+;;; set the default connection to pick which Lisp handles commands in
+;;; Lisp-mode source buffers, and slime hackers should be aware that
+;;; they can tie a buffer to a specific connection. The rest takes
+;;; care of itself.
+
+(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'.")
+
+(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 connection to use by default.
+Used for all Lisp communication, except when overridden by
+`slime-dispatching-connection' or `slime-buffer-connection'.")
+
+(defun slime-current-connection ()
+ "Return the connection to use for Lisp interaction.
+Return nil if there's no connection."
+ (or slime-dispatching-connection
+ slime-buffer-connection
+ slime-default-connection))
+
+(defun slime-connection ()
+ "Return the connection to use for Lisp interaction.
+Signal an error if there's no connection."
+ (let ((conn (slime-current-connection)))
+ (cond ((and (not conn) slime-net-processes)
+ (error "No default connection selected."))
+ ((not conn)
+ (error "Not connected."))
+ ((not (eq (process-status conn) 'open))
+ (error "Connection closed."))
+ (t conn))))
+
+(defun slime-select-connection (process)
+ "Make PROCESS the default connection."
+ (setq slime-default-connection process))
+
+(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.
+
+\(fn (&optional PROCESS) &body BODY))"
+ `(with-current-buffer
+ (process-buffer (or ,process (slime-connection)
+ (error "No connection")))
+ ,@body))
+
+(put 'slime-with-connection-buffer 'lisp-indent-function 1)
+
+(defvar slime-state-name "[??]"
+ "Name of the current state of `slime-default-connection'.
+Just used for informational display in the mode-line.")
+
+(defun slime-set-state (name &optional connection)
+ "Set the current connection's informational state name.
+If this is the default connection then the state will be displayed in
+the modeline."
+ (when (or (not (slime-connected-p))
+ (eq (or connection (slime-connection)) slime-default-connection))
+ (setq slime-state-name name)
+ (force-mode-line-update)))
+
+;;; Connection-local variables:
+
+(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 ,@initial-value-and-doc))
+ ;; Accessor
+ (defun ,varname (&optional process)
+ (slime-with-connection-buffer (process) ,real-var))
+ ;; Setf
+ (defsetf ,varname (&optional process) (store)
+ `(slime-with-connection-buffer (,process)
+ (setq (\, (quote (\, real-var))) (\, store))
+ (\, store)))
+ '(\, varname))))
+
+(put 'slime-def-connection-var 'lisp-indent-function 2)
+
+;; Let's indulge in some pretty colours.
+(unless (featurep 'xemacs)
+ (font-lock-add-keywords
+ 'emacs-lisp-mode
+ '(("(\\(slime-def-connection-var\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face)))))
+
+(slime-def-connection-var slime-connection-number nil
+ "Serial number of a connection.
+Bound in the connection's process-buffer.")
+
+(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-modules '()
+ "The strings of Lisp's *MODULES*.")
+
+(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-lisp-package-prompt-string
+ "CL-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 slime-lisp-implementation-type nil
+ "The implementation type of the Lisp process.")
+
+(slime-def-connection-var slime-lisp-implementation-version nil
+ "The implementation type of the Lisp process.")
+
+(slime-def-connection-var slime-lisp-implementation-name nil
+ "The short name for the Lisp implementation.")
+
+(slime-def-connection-var slime-connection-name nil
+ "The short name for connection.")
+
+(slime-def-connection-var slime-inferior-process nil
+ "The inferior process for the connection if any.")
+
+(slime-def-connection-var slime-communication-style nil
+ "The communication style.")
+
+(slime-def-connection-var slime-machine-instance nil
+ "The name of the (remote) machine running the Lisp process.")
+
+;;;;; Connection setup
+
+(defvar slime-connection-counter 0
+ "The number of SLIME connections made. For generating serial numbers.")
+
+;;; Interface
+(defun slime-setup-connection (process)
+ "Make a connection out of PROCESS."
+ (let ((slime-dispatching-connection process))
+ (slime-init-connection-state process)
+ (slime-select-connection process)
+ process))
+
+(defun slime-init-connection-state (proc)
+ "Initialize connection state in the process-buffer of 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 proc))
+ (setq slime-connection-counter 0))
+ (slime-with-connection-buffer ()
+ (setq slime-buffer-connection proc))
+ (setf (slime-connection-number proc) (incf slime-connection-counter))
+ ;; We do the rest of our initialization asynchronously. The current
+ ;; function may be called from a timer, and if we setup the REPL
+ ;; from a timer then it mysteriously uses the wrong keymap for the
+ ;; first command.
+ (slime-eval-async '(swank:connection-info)
+ (with-lexical-bindings (proc)
+ (lambda (info)
+ (slime-set-connection-info proc info)))))
+
+(defun slime-set-connection-info (connection info)
+ "Initialize CONNECTION with INFO received from Lisp."
+ (let ((slime-dispatching-connection connection))
+ (destructuring-bind (&key pid style lisp-implementation machine
+ features package version modules
+ &allow-other-keys) info
+ (or (equal version slime-protocol-version)
+ (yes-or-no-p "Protocol version mismatch. Continue anyway? ")
+ (slime-net-close connection)
+ (top-level))
+ (setf (slime-pid) pid
+ (slime-communication-style) style
+ (slime-lisp-features) features
+ (slime-lisp-modules) modules)
+ (destructuring-bind (&key name prompt) package
+ (setf (slime-lisp-package) name
+ (slime-lisp-package-prompt-string) prompt))
+ (destructuring-bind (&key type name version) lisp-implementation
+ (setf (slime-lisp-implementation-type) type
+ (slime-lisp-implementation-version) version
+ (slime-lisp-implementation-name) name
+ (slime-connection-name) (slime-generate-connection-name name)))
+ (destructuring-bind (&key instance type version) machine
+ (setf (slime-machine-instance) instance)))
+ (setq slime-state-name "") ; FIXME
+ (let ((args (when-let (p (slime-inferior-process))
+ (slime-inferior-lisp-args p))))
+ (when-let (name (plist-get args ':name))
+ (unless (string= (slime-lisp-implementation-name) name)
+ (setf (slime-connection-name)
+ (slime-generate-connection-name (symbol-name name)))))
+ (slime-hide-inferior-lisp-buffer)
+ (slime-init-output-buffer connection)
+ (slime-load-contribs)
+ (run-hooks 'slime-connected-hook)
+ (when-let (fun (plist-get args ':init-function))
+ (funcall fun)))
+ (message "Connected. %s" (slime-random-words-of-encouragement))))
+
+(defun slime-generate-connection-name (lisp-name)
+ (loop for i from 1
+ for name = lisp-name then (format "%s<%d>" lisp-name i)
+ while (find name slime-net-processes
+ :key #'slime-connection-name :test #'equal)
+ finally (return name)))
+
+(defun slime-connection-close-hook (process)
+ (when (eq process slime-default-connection)
+ (when slime-net-processes
+ (slime-select-connection (car slime-net-processes))
+ (message "Default connection closed; switched to #%S (%S)"
+ (slime-connection-number)
+ (slime-connection-name)))))
+
+(add-hook 'slime-net-process-close-hooks 'slime-connection-close-hook)
+
+;;;;; Commands on connections
+
+(defun slime-disconnect ()
+ "Disconnect all connections."
+ (interactive)
+ (mapc #'slime-net-close slime-net-processes))
+
+(defun slime-make-default-connection ()
+ "Make the current connection the default connection."
+ (interactive)
+ (slime-select-connection (slime-connection))
+ (message "Connection #%S (%s) now default SLIME connection."
+ (slime-connection-number)
+ (slime-connection-name)))
+
+(defun slime-choose-connection ()
+ "Return an established connection chosen by the user."
+ (let ((default (slime-connection-name)))
+ (slime-find-connection-by-name
+ (completing-read (format "Connection name (default %s): " default)
+ (slime-bogus-completion-alist
+ (mapcar #'slime-connection-name slime-net-processes))
+ nil
+ t
+ nil
+ nil
+ default))))
+
+(defun slime-find-connection-by-name (name)
+ (find name slime-net-processes
+ :test #'string= :key #'slime-connection-name))
+
+(defun slime-connection-port (connection)
+ "Return the remote port number of CONNECTION."
+ (if (featurep 'xemacs)
+ (car (process-id connection))
+ (cadr (process-contact connection))))
+
+(defun slime-process (&optional connection)
+ "Return the Lisp process for CONNECTION (default `slime-connection').
+Can return nil if there's no process object for the connection."
+ (let ((proc (slime-inferior-process connection)))
+ (if (and proc
+ (memq (process-status proc) '(run stop)))
+ proc)))
+
+;; Non-macro version to keep the file byte-compilable.
+(defun slime-set-inferior-process (connection process)
+ (setf (slime-inferior-process connection) process))
+
+(defun slime-use-sigint-for-interrupt (&optional connection)
+ (let ((c (or connection (slime-connection))))
+ (ecase (slime-communication-style c)
+ ((:fd-handler nil) t)
+ ((:spawn :sigio) nil))))
+
+(defvar slime-inhibit-pipelining t
+ "*If true, don't send background requests if Lisp is already busy.")
+
+(defun slime-background-activities-enabled-p ()
+ (and (or slime-mode
+ (eq major-mode 'sldb-mode)
+ (eq major-mode 'slime-repl-mode))
+ (let ((con (slime-current-connection)))
+ (and con
+ (eq (process-status con) 'open)))
+ (or (not (slime-busy-p))
+ (not slime-inhibit-pipelining))))
+
+
+;;;; Communication protocol
+
+;;;;; Emacs Lisp programming interface
+;;;
+;;; The programming interface for writing Emacs commands is based on
+;;; remote procedure calls (RPCs). The basic operation is to ask Lisp
+;;; to apply a named Lisp function to some arguments, then to do
+;;; something with the result.
+;;;
+;;; Requests can be either synchronous (blocking) or asynchronous
+;;; (with the result passed to a callback/continuation function). If
+;;; an error occurs during the request then the debugger is entered
+;;; before the result arrives -- for synchronous evaluations this
+;;; requires a recursive edit.
+;;;
+;;; You should use asynchronous evaluations (`slime-eval-async') for
+;;; most things. Reserve synchronous evaluations (`slime-eval') for
+;;; the cases where blocking Emacs is really appropriate (like
+;;; completion) and that shouldn't trigger errors (e.g. not evaluate
+;;; user-entered code).
+;;;
+;;; We have the concept of the "current Lisp package". RPC requests
+;;; always say what package the user is making them from and the Lisp
+;;; side binds that package to *BUFFER-PACKAGE* to use as it sees
+;;; fit. The current package is defined as the buffer-local value of
+;;; `slime-buffer-package' if set, and otherwise the package named by
+;;; the nearest IN-PACKAGE as found by text search (first backwards,
+;;; then forwards).
+;;;
+;;; Similarly we have the concept of the current thread, i.e. which
+;;; thread in the Lisp process should handle the request. The current
+;;; thread is determined solely by the buffer-local value of
+;;; `slime-current-thread'. This is usually bound to t meaning "no
+;;; particular thread", but can also be used to nominate a specific
+;;; thread. The REPL and the debugger both use this feature to deal
+;;; with specific threads.
+
+(make-variable-buffer-local
+ (defvar slime-current-thread t
+ "The id of the current thread on the Lisp side.
+t means the \"current\" thread;
+:repl-thread the thread that executes REPL requests;
+fixnum a specific thread."))
+
+(make-variable-buffer-local
+ (defvar slime-buffer-package nil
+ "The Lisp package associated with the current buffer.
+This is set only in buffers bound to specific packages."))
+
+;;; `slime-rex' is the RPC primitive which is used to implement both
+;;; `slime-eval' and `slime-eval-async'. You can use it directly if
+;;; you need to, but the others are usually more convenient.
+
+(defmacro* slime-rex ((&rest saved-vars)
+ (sexp &optional
+ (package '(slime-current-package))
+ (thread 'slime-current-thread))
+ &rest continuations)
+ "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) 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 binds *BUFFER-PACKAGE* to this package.
+The default value is (slime-current-package).
+
+CLAUSES is a list of patterns with same syntax as
+`destructure-case'. The result of the evaluation of SEXP 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)))
+ (slime-dispatch-event
+ (list :emacs-rex ,sexp ,package ,thread
+ (lambda (,result)
+ (destructure-case ,result
+ ,@continuations)))))))
+
+(put 'slime-rex 'lisp-indent-function 2)
+
+;;; Interface
+(defun slime-current-package ()
+ "Return the Common Lisp package in the current context.
+If `slime-buffer-package' has a value then return that, otherwise
+search for and read an `in-package' form.
+
+The REPL buffer is a special case: it's package is `slime-lisp-package'."
+ (cond ((eq major-mode 'slime-repl-mode)
+ (slime-lisp-package))
+ (slime-buffer-package)
+ (t (save-restriction
+ (widen)
+ (slime-find-buffer-package)))))
+
+(defvar slime-find-buffer-package-function 'slime-search-buffer-package
+ "*Function to use for `slime-find-buffer-package'.
+The result should be the package-name (a string)
+or nil if nothing suitable can be found.")
+
+(defun slime-find-buffer-package ()
+ "Figure out which Lisp package the current buffer is associated with."
+ (funcall slime-find-buffer-package-function))
+
+;; When modifing this code consider cases like:
+;; (in-package #.*foo*)
+;; (in-package #:cl)
+;; (in-package :cl)
+;; (in-package "CL")
+;; (in-package |CL|)
+;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp)
+(defun slime-search-buffer-package ()
+ (let ((case-fold-search t)
+ (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
+ "\\([^)]+\\)[ \t]*)")))
+ (save-excursion
+ (when (or (re-search-backward regexp nil t)
+ (re-search-forward regexp nil t))
+ (match-string-no-properties 2)))))
+
+;;; Synchronous requests are implemented in terms of asynchronous
+;;; ones. We make an asynchronous request with a continuation function
+;;; that `throw's its result up to a `catch' and then enter a loop of
+;;; handling I/O until that happens.
+
+(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."
+ (when (null package) (setq package (slime-current-package)))
+ (let* ((tag (gensym (format "slime-result-%d-"
+ (1+ (slime-continuation-counter)))))
+ (slime-stack-eval-tags (cons tag slime-stack-eval-tags)))
+ (apply
+ #'funcall
+ (catch tag
+ (slime-rex (tag sexp)
+ (sexp package)
+ ((:ok value)
+ (unless (member tag slime-stack-eval-tags)
+ (error "tag = %S eval-tags = %S sexp = %S"
+ tag slime-stack-eval-tags sexp))
+ (throw tag (list #'identity value)))
+ ((:abort)
+ (throw tag (list #'error "Synchronous Lisp Evaluation aborted."))))
+ (let ((debug-on-quit t)
+ (inhibit-quit nil)
+ (conn (slime-connection)))
+ (while t
+ (unless (eq (process-status conn) 'open)
+ (error "Lisp connection closed unexpectedly"))
+ (slime-accept-process-output nil 0.01)))))))
+
+(defun slime-eval-async (sexp &optional cont package)
+ "Evaluate EXPR on the superior Lisp and call CONT with the result."
+ (slime-rex (cont (buffer (current-buffer)))
+ (sexp (or package (slime-current-package)))
+ ((:ok result)
+ (when cont
+ (set-buffer buffer)
+ (funcall cont result)))
+ ((:abort)
+ (message "Evaluation aborted."))))
+
+;;; These functions can be handy too:
+
+(defun slime-connected-p ()
+ "Return true if the Swank connection is open."
+ (not (null slime-net-processes)))
+
+(defun slime-check-connected ()
+ "Signal an error if we are not connected to Lisp."
+ (unless (slime-connected-p)
+ (error "Not connected. Use `%s' to start a Lisp."
+ (substitute-command-keys "\\[slime]"))))
+
+(defun slime-busy-p ()
+ "True if Lisp has outstanding requests.
+Debugged requests are ignored."
+ (let ((debugged (sldb-debugged-continuations (slime-connection))))
+ (remove-if (lambda (id)
+ (memq id debugged))
+ (slime-rex-continuations)
+ :key #'car)))
+
+;; dummy defvar for compiler
+(defvar slime-repl-read-mode)
+
+(defun slime-reading-p ()
+ "True if Lisp is currently reading input from the REPL."
+ (with-current-buffer (slime-output-buffer)
+ slime-repl-read-mode))
+
+(defun slime-sync ()
+ "Block until the most recent request has finished."
+ (when (slime-rex-continuations)
+ (let ((tag (caar (slime-rex-continuations))))
+ (while (find tag (slime-rex-continuations) :key #'car)
+ (slime-accept-process-output nil 0.1)))))
+
+(defun slime-ping ()
+ "Check that communication works."
+ (interactive)
+ (message "%s" (slime-eval "PONG")))
+
+;;;;; Protocol event handler (the guts)
+;;;
+;;; This is the protocol in all its glory. The input to this function
+;;; is a protocol event that either originates within Emacs or arrived
+;;; over the network from Lisp.
+;;;
+;;; Each event is a list beginning with a keyword and followed by
+;;; arguments. The keyword identifies the type of event. Events
+;;; originating from Emacs have names starting with :emacs- and events
+;;; from Lisp don't.
+
+(slime-def-connection-var slime-rex-continuations '()
+ "List of (ID . FUNCTION) continuations waiting for RPC results.")
+
+(slime-def-connection-var slime-continuation-counter 0
+ "Continuation serial number counter.")
+
+(defvar slime-event-hooks)
+
+(defun slime-dispatch-event (event &optional process)
+ (let ((slime-dispatching-connection (or process (slime-connection))))
+ (or (run-hook-with-args-until-success 'slime-event-hooks event)
+ (destructure-case event
+ ((:write-string output &optional target)
+ (slime-write-string output target))
+ ((:emacs-rex form package thread continuation)
+ (slime-set-state "|eval...")
+ (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
+ (message "; pipelined request... %S" form))
+ (let ((id (incf (slime-continuation-counter))))
+ (push (cons id continuation) (slime-rex-continuations))
+ (slime-send `(:emacs-rex ,form ,package ,thread ,id))))
+ ((:return value id)
+ (let ((rec (assq id (slime-rex-continuations))))
+ (cond (rec (setf (slime-rex-continuations)
+ (remove rec (slime-rex-continuations)))
+ (when (null (slime-rex-continuations))
+ (slime-set-state ""))
+ (funcall (cdr rec) value))
+ (t
+ (error "Unexpected reply: %S %S" id value)))))
+ ((:debug-activate thread level)
+ (assert thread)
+ (sldb-activate thread level))
+ ((:debug thread level condition restarts frames conts)
+ (assert thread)
+ (sldb-setup thread level condition restarts frames conts))
+ ((:debug-return thread level stepping)
+ (assert thread)
+ (sldb-exit thread level stepping))
+ ((:emacs-interrupt thread)
+ (slime-send `(:emacs-interrupt ,thread)))
+ ((:read-string thread tag)
+ (assert thread)
+ (slime-repl-read-string thread tag))
+ ((:y-or-n-p thread tag question)
+ (slime-y-or-n-p thread tag question))
+ ((:read-aborted thread tag)
+ (assert thread)
+ (slime-repl-abort-read thread tag))
+ ((:emacs-return-string thread tag string)
+ (slime-send `(:emacs-return-string ,thread ,tag ,string)))
+ ;;
+ ((:new-package package prompt-string)
+ (setf (slime-lisp-package) package)
+ (setf (slime-lisp-package-prompt-string) prompt-string))
+ ((:new-features features)
+ (setf (slime-lisp-features) features))
+ ((:indentation-update info)
+ (slime-handle-indentation-update info))
+ ((:open-dedicated-output-stream port)
+ (slime-open-stream-to-lisp port))
+ ((:eval-no-wait fun args)
+ (apply (intern fun) args))
+ ((:eval thread tag form-string)
+ (slime-check-eval-in-emacs-enabled)
+ (slime-eval-for-lisp thread tag form-string))
+ ((:emacs-return thread tag value)
+ (slime-send `(:emacs-return ,thread ,tag ,value)))
+ ((:ed what)
+ (slime-ed what))
+ ((:inspect what)
+ (slime-open-inspector what))
+ ((:background-message message)
+ (slime-background-message "%s" message))
+ ((:debug-condition thread message)
+ (assert thread)
+ (message "%s" message))))))
+
+(defun slime-send (sexp)
+ "Send SEXP directly over the wire on the current connection."
+ (slime-net-send sexp (slime-connection)))
+
+(defun slime-reset ()
+ "Clear all pending continuations."
+ (interactive)
+ (setf (slime-rex-continuations) '())
+ (mapc #'kill-buffer (sldb-buffers)))
+
+(defun slime-send-sigint ()
+ (interactive)
+ (signal-process (slime-pid) 'SIGINT))
+
+;;;;; Event logging to *slime-events*
+;;;
+;;; The *slime-events* buffer logs all protocol messages for debugging
+;;; purposes. Optionally you can enable outline-mode in that buffer,
+;;; which is convenient but slows things down significantly.
+
+(defvar slime-log-events t
+ "*Log protocol events to the *slime-events* buffer.")
+
+(defvar slime-outline-mode-in-events-buffer nil
+ "*Non-nil means use outline-mode in *slime-events*.")
+
+(defvar slime-event-buffer-name "*slime-events*"
+ "The name of the slime event buffer.")
+
+(defun slime-log-event (event)
+ "Record the fact that EVENT occurred."
+ (when slime-log-events
+ (with-current-buffer (slime-events-buffer)
+ ;; trim?
+ (when (> (buffer-size) 100000)
+ (goto-char (/ (buffer-size) 2))
+ (re-search-forward "^(" nil t)
+ (delete-region (point-min) (point)))
+ (goto-char (point-max))
+ (save-excursion
+ (slime-pprint-event event (current-buffer)))
+ (when (and (boundp 'outline-minor-mode)
+ outline-minor-mode)
+ (hide-entry))
+ (goto-char (point-max)))))
+
+(defun slime-pprint-event (event buffer)
+ "Pretty print EVENT in BUFFER with limited depth and width."
+ (let ((print-length 20)
+ (print-level 6)
+ (pp-escape-newlines t))
+ (pp event buffer)))
+
+(defun slime-events-buffer ()
+ (or (get-buffer slime-event-buffer-name)
+ (let ((buffer (get-buffer-create slime-event-buffer-name)))
+ (with-current-buffer buffer
+ (buffer-disable-undo)
+ (set (make-local-variable 'outline-regexp) "^(")
+ (set (make-local-variable 'comment-start) ";")
+ (set (make-local-variable 'comment-end) "")
+ (when slime-outline-mode-in-events-buffer
+ (outline-minor-mode)))
+ buffer)))
+
+
+;;;; Stream output
+
+(slime-def-connection-var slime-connection-output-buffer nil
+ "The buffer for the REPL. May be nil or a dead buffer.")
+
+(make-variable-buffer-local
+ (defvar slime-output-start nil
+ "Marker for the start of the output for the evaluation."))
+
+(make-variable-buffer-local
+ (defvar slime-output-end nil
+ "Marker for end of output. New output is inserted at this mark."))
+
+;; dummy definitions for the compiler
+(defvar slime-repl-package-stack)
+(defvar slime-repl-directory-stack)
+(defvar slime-repl-input-start-mark)
+(defvar slime-repl-prompt-start-mark)
+
+
+(defun slime-output-buffer (&optional noprompt)
+ "Return the output buffer, create it if necessary."
+ (let ((buffer (slime-connection-output-buffer)))
+ (or (if (buffer-live-p buffer) buffer)
+ (setf (slime-connection-output-buffer)
+ (let ((connection (slime-connection)))
+ (with-current-buffer (slime-repl-buffer t connection)
+ (unless (eq major-mode 'slime-repl-mode)
+ (slime-repl-mode))
+ (setq slime-buffer-connection connection)
+ (slime-reset-repl-markers)
+ (unless noprompt
+ (slime-repl-insert-prompt))
+ (current-buffer)))))))
+
+(defvar slime-repl-banner-function 'slime-repl-insert-banner)
+
+(defun slime-repl-update-banner ()
+ (funcall slime-repl-banner-function)
+ (goto-char (point-max))
+ (slime-mark-output-start)
+ (slime-mark-input-start)
+ (slime-repl-insert-prompt)
+ (pop-to-buffer (current-buffer)))
+
+(defun slime-repl-insert-banner ()
+ (when (zerop (buffer-size))
+ (let ((welcome (concat "; SLIME " (or (slime-changelog-date)
+ "- ChangeLog file not found"))))
+ (insert welcome))))
+
+(defun slime-init-output-buffer (connection)
+ (with-current-buffer (slime-output-buffer t)
+ (setq slime-buffer-connection connection
+ slime-repl-directory-stack '()
+ slime-repl-package-stack '())
+ (slime-repl-update-banner)))
+
+(defvar slime-show-last-output-function
+ 'slime-maybe-display-output-buffer
+ "*This function is called when a evaluation request is finished.
+It is called in the slime-output buffer and receives the region of the
+output as arguments.")
+
+(defun slime-show-last-output-region (start end)
+ (when (< start end)
+ (slime-display-buffer-region (current-buffer) (1- start)
+ slime-repl-input-start-mark)))
+
+(defun slime-maybe-display-output-buffer (start end)
+ (when (and (< start end)
+ (not (get-buffer-window (current-buffer) t)))
+ (display-buffer (current-buffer)))
+ (when (eobp)
+ (slime-repl-show-maximum-output t)))
+
+(defun slime-show-last-output ()
+ "Show the output from the last Lisp evaluation."
+ (with-current-buffer (slime-output-buffer)
+ (let ((start slime-output-start)
+ (end slime-output-end))
+ (funcall slime-show-last-output-function start end))))
+
+(defun slime-display-output-buffer ()
+ "Display the output buffer and scroll to bottom."
+ (with-current-buffer (slime-output-buffer)
+ (goto-char (point-max))
+ (unless (get-buffer-window (current-buffer) t)
+ (display-buffer (current-buffer) t))
+ (slime-repl-show-maximum-output)))
+
+(defmacro slime-with-output-end-mark (&rest body)
+ "Execute BODY at `slime-output-end'.
+
+If point is initially at `slime-output-end' and the buffer is visible
+update window-point afterwards. If point is initially not at
+`slime-output-end, execute body inside a `save-excursion' block."
+ `(let ((body.. (lambda () ,@body))
+ (updatep.. (and (eobp) (pos-visible-in-window-p))))
+ (cond ((= (point) slime-output-end)
+ (let ((start.. (point)))
+ (funcall body..)
+ (set-marker slime-output-end (point))
+ (when (= start.. slime-repl-input-start-mark)
+ (set-marker slime-repl-input-start-mark (point)))))
+ (t
+ (save-excursion
+ (goto-char slime-output-end)
+ (funcall body..))))
+ (when updatep..
+ (slime-repl-show-maximum-output
+ (> (- slime-output-end slime-output-start) 1000)))))
+
+(defun slime-output-filter (process string)
+ (with-current-buffer (process-buffer process)
+ (when (and (plusp (length string))
+ (eq (process-status slime-buffer-connection) 'open))
+ (slime-write-string string))))
+
+(defvar slime-open-stream-hooks)
+
+(defun slime-open-stream-to-lisp (port)
+ (let ((stream (open-network-stream "*lisp-output-stream*"
+ (slime-with-connection-buffer ()
+ (current-buffer))
+ slime-lisp-host port)))
+ (slime-set-query-on-exit-flag stream)
+ (set-process-filter stream 'slime-output-filter)
+ (let ((pcs (process-coding-system (slime-current-connection))))
+ (set-process-coding-system stream (car pcs) (cdr pcs)))
+ (when-let (secret (slime-secret))
+ (slime-net-send secret stream))
+ (run-hook-with-args 'slime-open-stream-hooks stream)
+ stream))
+
+(defun slime-io-speed-test (&optional profile)
+ "A simple minded benchmark for stream performance.
+If a prefix argument is given, instrument the slime package for
+profiling before running the benchmark."
+ (interactive "P")
+ (eval-and-compile
+ (require 'elp))
+ (elp-reset-all)
+ (elp-restore-all)
+ (load "slime.el")
+ ;;(byte-compile-file "slime-net.el" t)
+ ;;(setq slime-log-events nil)
+ (setq slime-enable-evaluate-in-emacs t)
+ ;;(setq slime-repl-enable-presentations nil)
+ (when profile
+ (elp-instrument-package "slime-"))
+ (kill-buffer (slime-output-buffer))
+ ;;(display-buffer (slime-output-buffer))
+ (delete-other-windows)
+ (sit-for 0)
+ (slime-repl-send-string "(swank:io-speed-test 5000 1)")
+ (let ((proc (slime-inferior-process)))
+ (when proc
+ (switch-to-buffer (process-buffer proc))
+ (goto-char (point-max)))))
+
+(defvar slime-write-string-function 'slime-repl-write-string)
+
+(defun slime-write-string (string &optional target)
+ "Insert STRING in the REPL buffer or some other TARGET.
+If TARGET is nil, insert STRING as regular process
+output. If TARGET is :repl-result, insert STRING as the result of the
+evaluation. Other values of TARGET map to an Emacs marker via the
+hashtable `slime-output-target-to-marker'; output is inserted at this marker."
+ (funcall slime-write-string-function string target))
+
+(defun slime-repl-write-string (string &optional target)
+ (case target
+ ((nil) (slime-repl-emit string))
+ (:repl-result (slime-repl-emit-result string))
+ (t (slime-emit-string string target))))
+
+(defun slime-repl-emit (string)
+ ;; insert the string STRING in the output buffer
+ (with-current-buffer (slime-output-buffer)
+ (slime-with-output-end-mark
+ (slime-insert-propertized '(face slime-repl-output-face
+ rear-nonsticky (face))
+ string)
+ (set-marker slime-output-end (point))
+ (when (and (= (point) slime-repl-prompt-start-mark)
+ (not (bolp)))
+ (insert "\n")
+ (set-marker slime-output-end (1- (point))))
+ (when (< slime-repl-input-start-mark (point))
+ (set-marker slime-repl-input-start-mark (point))))))
+
+(defun slime-repl-emit-result (string &optional bol)
+ ;; insert STRING and mark it as evaluation result
+ (with-current-buffer (slime-output-buffer)
+ (goto-char slime-repl-input-start-mark)
+ (when (and bol (not (bolp))) (insert "\n"))
+ (slime-insert-propertized `(face slime-repl-result-face
+ rear-nonsticky (face))
+ string)
+ (set-marker slime-repl-input-start-mark (point))))
+
+(defvar slime-last-output-target-id 0
+ "The last integer we used as a TARGET id.")
+
+(defvar slime-output-target-to-marker
+ (make-hash-table)
+ "Map from TARGET ids to Emacs markers.
+The markers indicate where output should be inserted.")
+
+(defun slime-output-target-marker (target)
+ "Return the marker where output for TARGET should be inserted."
+ (case target
+ ((nil)
+ (with-current-buffer (slime-output-buffer)
+ slime-output-end))
+ (:repl-result
+ (with-current-buffer (slime-output-buffer)
+ slime-repl-input-start-mark))
+ (t
+ (gethash target slime-output-target-to-marker))))
+
+(defun slime-emit-string (string target)
+ "Insert STRING at target TARGET.
+See `slime-output-target-to-marker'."
+ (let* ((marker (slime-output-target-marker target))
+ (buffer (and marker (marker-buffer marker))))
+ (when buffer
+ (with-current-buffer buffer
+ (save-excursion
+ ;; Insert STRING at MARKER, then move MARKER behind
+ ;; the insertion.
+ (goto-char marker)
+ (insert-before-markers string)
+ (set-marker marker (point)))))))
+
+(defun slime-switch-to-output-buffer (&optional connection)
+ "Select the output buffer, preferably in a different window."
+ (interactive (list (if prefix-arg (slime-choose-connection))))
+ (let ((slime-dispatching-connection (or connection
+ slime-dispatching-connection)))
+ (set-buffer (slime-output-buffer))
+ (unless (eq (current-buffer) (window-buffer))
+ (pop-to-buffer (current-buffer) t))
+ (goto-char (point-max))))
+
+
+;;;; REPL
+;;
+;; The REPL uses some markers to separate input from output. The
+;; usual configuration is as follows:
+;;
+;; ... output ... ... result ... prompt> ... input ...
+;; ^ ^ ^ ^ ^
+;; output-start output-end prompt-start input-start input-end
+;;
+;; output-start and input-start are right inserting markers;
+;; output-end and input-end left inserting.
+;;
+;; We maintain the following invariant:
+;;
+;; output-start <= output-end <= input-start <= input-end.
+;;
+;; This invariant is important, because we must be prepared for
+;; asynchronous output and asynchronous reads. ("Asynchronous" means,
+;; triggered by Lisp and not by Emacs.)
+;;
+;; All output is inserted at the output-end marker. Some care must be
+;; taken when output-end and input-start are at the same position: if
+;; we blindly insert at that point, we break the invariant stated
+;; above, because the output-end marker is left inserting. The macro
+;; `slime-with-output-end-mark' handles this complication by moving
+;; the input-start marker to an appropriate place. The macro also
+;; updates window-point if necessary, and tries to keep the prompt in
+;; the first column by inserting a newline.
+;;
+;; A "synchronous" evaluation request proceeds as follows: the user
+;; inserts some text between input-start and input-end and then hits
+;; return. We send the text between the input markers to Lisp, move
+;; the output and input makers to the line after the input and wait.
+;; When we receive the result, we insert it together with a prompt
+;; between the output-end and input-start mark.
+;; `slime-repl-insert-prompt' does this.
+;;
+;; It is possible that some output for such an evaluation request
+;; arrives after the result. This output is inserted before the
+;; result (and before the prompt). Output that doesn't belong the
+;; evaluation request should not be inserted before the result, but
+;; immediately before the prompt. To achieve this, we move the
+;; output-end mark to prompt-start after a short delay (by starting a
+;; timer in `slime-repl-insert-prompt'). In summary: synchronous
+;; output should go before the result, asynchronous before the prompt.
+;;
+;; If we are in "reading" state, e.g., during a call to Y-OR-N-P,
+;; there is no prompt between output-end and input-start.
+;;
+
+;; Small helper.
+(defun slime-make-variables-buffer-local (&rest variables)
+ (mapcar #'make-variable-buffer-local variables))
+
+(slime-make-variables-buffer-local
+ (defvar slime-repl-package-stack nil
+ "The stack of packages visited in this repl.")
+
+ (defvar slime-repl-directory-stack nil
+ "The stack of default directories associated with this repl.")
+
+ (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-old-input-counter 0
+ "Counter used to generate unique `slime-repl-old-input' properties.
+This property value must be unique to avoid having adjacent inputs be
+joined together."))
+
+(defun slime-reset-repl-markers ()
+ (dolist (markname '(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-output-end t)
+ (set-marker-insertion-type slime-repl-input-end-mark t)
+ (set-marker-insertion-type slime-repl-prompt-start-mark t))
+
+;;;;; REPL mode setup
+
+(defvar slime-repl-mode-map)
+
+(setq slime-repl-mode-map (make-sparse-keymap))
+(set-keymap-parent slime-repl-mode-map lisp-mode-map)
+
+(dolist (spec slime-keys)
+ (destructuring-bind (key command &key inferior prefixed
+ &allow-other-keys) spec
+ (when inferior
+ (let ((key (if prefixed (concat slime-prefix-key key) key)))
+ (define-key slime-repl-mode-map key command)))))
+
+(slime-define-keys slime-repl-mode-map
+ ("\C-m" 'slime-repl-return)
+ ([return] 'slime-repl-return)
+ ("\C-j" 'slime-repl-newline-and-indent)
+ ("\C-\M-m" 'slime-repl-closing-return)
+ ([(control return)] 'slime-repl-closing-return)
+ ("\C-a" 'slime-repl-bol)
+ ([home] 'slime-repl-bol)
+ ("\C-e" 'slime-repl-eol)
+ ("\M-p" 'slime-repl-previous-input)
+ ((kbd "C-<up>") 'slime-repl-backward-input)
+ ("\M-n" 'slime-repl-next-input)
+ ((kbd "C-<down>") 'slime-repl-forward-input)
+ ("\M-r" 'slime-repl-previous-matching-input)
+ ("\M-s" 'slime-repl-next-matching-input)
+ ("\C-c\C-c" 'slime-interrupt)
+ ("\C-c\C-b" 'slime-interrupt)
+ ("\C-c:" 'slime-interactive-eval)
+ ("\C-c\C-e" 'slime-interactive-eval)
+ ("\C-cE" 'slime-edit-value)
+ ;("\t" 'slime-complete-symbol)
+ ("\t" 'slime-indent-and-complete-symbol)
+ (" " 'slime-space)
+ ("\C-c\C-d" slime-doc-map)
+ ("\C-c\C-w" slime-who-map)
+ ("\C-\M-x" 'slime-eval-defun)
+ ("\C-c\C-o" 'slime-repl-clear-output)
+ ("\C-c\M-o" 'slime-repl-clear-buffer)
+ ("\C-c\C-t" 'slime-toggle-trace-fdefinition)
+ ("\C-c\C-u" 'slime-repl-kill-input)
+ ("\C-c\C-n" 'slime-repl-next-prompt)
+ ("\C-c\C-p" 'slime-repl-previous-prompt)
+ ("\C-c\C-l" 'slime-load-file)
+ ("\C-c\C-k" 'slime-compile-and-load-file)
+ ("\C-c\C-z" 'slime-nop))
+
+(defun slime-repl-mode ()
+ "Major mode for interacting with a superior Lisp.
+\\{slime-repl-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'slime-repl-mode)
+ (use-local-map slime-repl-mode-map)
+ (lisp-mode-variables t)
+ (set (make-local-variable 'lisp-indent-function)
+ 'common-lisp-indent-function)
+ (setq font-lock-defaults nil)
+ (setq mode-name "REPL")
+ (setq slime-current-thread :repl-thread)
+ (set (make-local-variable 'scroll-conservatively) 20)
+ (set (make-local-variable 'scroll-margin) 0)
+ (slime-repl-safe-load-history)
+ (add-local-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history)
+ (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories)
+ (slime-setup-command-hooks)
+ ;; At the REPL, we define beginning-of-defun and end-of-defun to be
+ ;; the start of the previous prompt or next prompt respectively.
+ ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN.
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'slime-repl-mode-beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function)
+ 'slime-repl-mode-end-of-defun)
+ (run-hooks 'slime-repl-mode-hook))
+
+(defun slime-repl-buffer (&optional create connection)
+ "Get the REPL buffer for the current connection; optionally create."
+ (funcall (if create #'get-buffer-create #'get-buffer)
+ (format "*slime-repl %s*" (slime-connection-name connection))))
+
+(defun slime-repl ()
+ (interactive)
+ (slime-switch-to-output-buffer))
+
+(defun slime-repl-mode-beginning-of-defun ()
+ (slime-repl-previous-prompt)
+ t)
+
+(defun slime-repl-mode-end-of-defun ()
+ (slime-repl-next-prompt)
+ t)
+
+(defun slime-repl-send-string (string &optional command-string)
+ (cond (slime-repl-read-mode
+ (slime-repl-return-string string))
+ (t (slime-repl-eval-string string))))
+
+(defun slime-repl-eval-string (string)
+ (slime-rex ()
+ ((list 'swank:listener-eval string) (slime-lisp-package))
+ ((:ok result)
+ (slime-repl-insert-result result))
+ ((:abort)
+ (slime-repl-show-abort))))
+
+(defun slime-repl-insert-result (result)
+ (with-current-buffer (slime-output-buffer)
+ (goto-char (point-max))
+ (when result
+ (destructure-case result
+ ((:values &rest strings)
+ (cond ((null strings)
+ (slime-repl-emit-result "; No value\n" t))
+ (t
+ (dolist (s strings)
+ (slime-repl-emit-result s t)))))))
+ (slime-repl-insert-prompt)))
+
+(defun slime-repl-show-abort ()
+ (with-current-buffer (slime-output-buffer)
+ (slime-with-output-end-mark
+ (unless (bolp) (insert-before-markers "\n"))
+ (insert-before-markers "; Evaluation aborted.\n"))
+ (slime-repl-insert-prompt)))
+
+(defun slime-repl-insert-prompt ()
+ "Goto to point max, and insert the prompt."
+ (goto-char slime-repl-input-start-mark)
+ (assert (= slime-repl-input-end-mark (point-max)))
+ (unless (bolp) (insert "\n"))
+ (let ((prompt-start (point))
+ (prompt (format "%s> " (slime-lisp-package-prompt-string))))
+ (slime-propertize-region
+ '(face slime-repl-prompt-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-before-markers prompt))
+ (slime-mark-input-start)
+ (set-marker slime-repl-input-end-mark (point-max))
+ (set-marker slime-repl-prompt-start-mark prompt-start)
+ (goto-char slime-repl-prompt-start-mark)
+ (slime-mark-output-start)
+ (goto-char (point-max)))
+ (slime-repl-show-maximum-output))
+
+(defun slime-repl-show-maximum-output (&optional force)
+ "Put the end of the buffer at the bottom of the window."
+ (assert (eobp))
+ (let ((win (get-buffer-window (current-buffer))))
+ (when win
+ (with-selected-window win
+ (recenter -1)))))
+
+(defvar slime-repl-current-input-hooks)
+
+(defun slime-repl-current-input (&optional until-point-p)
+ "Return the current input as string.
+The input is the region from after the last prompt to the end of
+buffer."
+ (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks
+ until-point-p)
+ (buffer-substring-no-properties
+ slime-repl-input-start-mark
+ (if (and until-point-p (<= (point) slime-repl-input-end-mark))
+ (point)
+ slime-repl-input-end-mark))))
+
+(defun slime-property-position (text-property &optional object)
+ "Return the first position of TEXT-PROPERTY, or nil."
+ (if (get-text-property 0 text-property object)
+ 0
+ (next-single-property-change 0 text-property object)))
+
+(defun slime-mark-input-start ()
+ (set-marker slime-repl-last-input-start-mark
+ (marker-position slime-repl-input-start-mark))
+ (set-marker slime-repl-input-start-mark (point) (current-buffer))
+ (set-marker slime-repl-input-end-mark (point) (current-buffer)))
+
+(defun slime-mark-output-start (&optional position)
+ (let ((position (or position (point))))
+ (set-marker slime-output-start position)
+ (set-marker slime-output-end position)))
+
+(defun slime-mark-output-end ()
+ ;; Don't put slime-repl-output-face again; it would remove the
+ ;; special presentation face, for instance in the SBCL inspector.
+ (add-text-properties slime-output-start slime-output-end
+ '(;;face slime-repl-output-face
+ rear-nonsticky (face))))
+
+(defun slime-repl-bol ()
+ "Go to the beginning of line or the prompt."
+ (interactive)
+ (cond ((and (>= (point) slime-repl-input-start-mark)
+ (slime-same-line-p (point) slime-repl-input-start-mark))
+ (goto-char slime-repl-input-start-mark))
+ (t (beginning-of-line 1)))
+ (slime-preserve-zmacs-region))
+
+(defun slime-repl-eol ()
+ "Go to the end of line or the prompt."
+ (interactive)
+ (if (and (<= (point) slime-repl-input-end-mark)
+ (slime-same-line-p (point) slime-repl-input-end-mark))
+ (goto-char slime-repl-input-end-mark)
+ (end-of-line 1))
+ (slime-preserve-zmacs-region))
+
+(defun slime-preserve-zmacs-region ()
+ "In XEmacs, ensure that the zmacs-region stays active after this command."
+ (when (boundp 'zmacs-region-stays)
+ (set 'zmacs-region-stays t)))
+
+(defun slime-repl-in-input-area-p ()
+ (and (<= slime-repl-input-start-mark (point))
+ (<= (point) slime-repl-input-end-mark)))
+
+(defun slime-repl-at-prompt-start-p ()
+ ;; This will not work on non-current prompts.
+ (= (point) slime-repl-input-start-mark))
+
+(defun slime-repl-beginning-of-defun ()
+ "Move to beginning of defun."
+ (interactive)
+ ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt
+ ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means
+ ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to
+ ;; jump to the start of the previous prompt.
+ (if (and (not (slime-repl-at-prompt-start-p))
+ (slime-repl-in-input-area-p))
+ (goto-char slime-repl-input-start-mark)
+ (beginning-of-defun))
+ t)
+
+(defun slime-repl-end-of-defun ()
+ "Move to next of defun."
+ (interactive)
+ ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN.
+ (if (and (not (= (point) slime-repl-input-end-mark))
+ (slime-repl-in-input-area-p))
+ (goto-char slime-repl-input-end-mark)
+ (end-of-defun))
+ t)
+
+;; FIXME: Shouldn't this be (= (point) slime-repl-input-end-mark)?
+(defun slime-repl-at-prompt-end-p ()
+ (and (get-char-property (max 1 (1- (point))) 'slime-repl-prompt)
+ (not (get-char-property (point) 'slime-repl-prompt))))
+
+(defun slime-repl-find-prompt (move)
+ (let ((origin (point)))
+ (loop (funcall move)
+ (when (or (slime-repl-at-prompt-end-p) (bobp) (eobp))
+ (return)))
+ (unless (slime-repl-at-prompt-end-p)
+ (goto-char origin))))
+
+(defun slime-search-property-change-fn (prop &optional backward)
+ (with-lexical-bindings (prop)
+ (if backward
+ (lambda ()
+ (goto-char
+ (previous-single-char-property-change (point) prop)))
+ (lambda ()
+ (goto-char
+ (next-single-char-property-change (point) prop))))))
+
+(defun slime-repl-previous-prompt ()
+ "Move backward to the previous prompt."
+ (interactive)
+ (slime-repl-find-prompt
+ (slime-search-property-change-fn 'slime-repl-prompt t)))
+
+(defun slime-repl-next-prompt ()
+ "Move forward to the next prompt."
+ (interactive)
+ (slime-repl-find-prompt
+ (slime-search-property-change-fn 'slime-repl-prompt)))
+
+(defvar slime-repl-return-hooks)
+
+(defun slime-repl-return (&optional end-of-input)
+ "Evaluate the current input string, or insert a newline.
+Send the current input ony if a whole expression has been entered,
+i.e. the parenthesis are matched.
+
+With prefix argument send the input even if the parenthesis are not
+balanced."
+ (interactive "P")
+ (slime-check-connected)
+ (assert (<= (point) slime-repl-input-end-mark))
+ (cond (end-of-input
+ (slime-repl-send-input))
+ (slime-repl-read-mode ; bad style?
+ (slime-repl-send-input t))
+ ((and (get-text-property (point) 'slime-repl-old-input)
+ (< (point) slime-repl-input-start-mark))
+ (slime-repl-grab-old-input end-of-input)
+ (slime-repl-recenter-if-needed))
+ ((run-hook-with-args-until-success 'slime-repl-return-hooks))
+ ((slime-input-complete-p slime-repl-input-start-mark
+ (ecase slime-repl-return-behaviour
+ (:send-only-if-after-complete (min (point) slime-repl-input-end-mark))
+ (:send-if-complete slime-repl-input-end-mark)))
+ (slime-repl-send-input t))
+ (t
+ (slime-repl-newline-and-indent)
+ (message "[input not complete]"))))
+
+(defun slime-repl-recenter-if-needed ()
+ "Make sure that slime-repl-input-end-mark is visible."
+ (unless (pos-visible-in-window-p slime-repl-input-end-mark)
+ (save-excursion
+ (goto-char slime-repl-input-end-mark)
+ (recenter -1))))
+
+(defun slime-repl-send-input (&optional newline)
+ "Goto to the end of the input and send the current input.
+If NEWLINE is true then add a newline at the end of the input."
+ (when (< (point) slime-repl-input-start-mark)
+ (error "No input at point."))
+ (goto-char slime-repl-input-end-mark)
+ (let ((end (point))) ; end of input, without the newline
+ (slime-repl-add-to-input-history
+ (buffer-substring slime-repl-input-start-mark end))
+ (when newline
+ (insert "\n")
+ (slime-repl-show-maximum-output))
+ (let ((inhibit-read-only t))
+ (add-text-properties slime-repl-input-start-mark
+ (point)
+ `(slime-repl-old-input
+ ,(incf slime-repl-old-input-counter))))
+ (let ((overlay (make-overlay slime-repl-input-start-mark end)))
+ ;; These properties are on an overlay so that they won't be taken
+ ;; by kill/yank.
+ (overlay-put overlay 'read-only t)
+ (overlay-put overlay 'face 'slime-repl-input-face)))
+ (let ((input (slime-repl-current-input)))
+ (goto-char slime-repl-input-end-mark)
+ (slime-mark-input-start)
+ (slime-mark-output-start)
+ (slime-repl-send-string input)))
+
+(defun slime-repl-grab-old-input (replace)
+ "Resend the old REPL input at point.
+If replace is non-nil the current input is replaced with the old
+input; otherwise the new input is appended. The old input has the
+text property `slime-repl-old-input'."
+ (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input)
+ (let ((old-input (buffer-substring beg end)) ;;preserve
+ ;;properties, they will be removed later
+ (offset (- (point) beg)))
+ ;; Append the old input or replace the current input
+ (cond (replace (goto-char slime-repl-input-start-mark))
+ (t (goto-char slime-repl-input-end-mark)
+ (unless (eq (char-before) ?\ )
+ (insert " "))))
+ (delete-region (point) slime-repl-input-end-mark)
+ (save-excursion (insert old-input))
+ (forward-char offset))))
+
+(defun slime-property-bounds (prop)
+ "Return two the positions of the previous and next changes to PROP.
+PROP is the name of a text property."
+ (let* ((beg (save-excursion
+ ;; previous-single-char-property-change searches for a
+ ;; property change from the previous character, but we
+ ;; want to look for a change from the point. We step
+ ;; forward one char to avoid doing the wrong thing if
+ ;; we're at the beginning of the old input. -luke
+ ;; (18/Jun/2004)
+ (unless (not (get-text-property (point) prop))
+ ;; alanr unless we are sitting right after it May 19, 2005
+ (ignore-errors (forward-char)))
+ (previous-single-char-property-change (point) prop)))
+ (end (save-excursion
+ (if (get-text-property (point) prop)
+ (progn (goto-char (next-single-char-property-change
+ (point) prop))
+ (skip-chars-backward "\n \t\r" beg)
+ (point))
+ (point)))))
+ (values beg end)))
+
+(defun slime-repl-closing-return ()
+ "Evaluate the current input string after closing all open lists."
+ (interactive)
+ (goto-char (point-max))
+ (save-restriction
+ (narrow-to-region slime-repl-input-start-mark (point))
+ (while (ignore-errors (save-excursion (backward-up-list 1)) t)
+ (insert ")")))
+ (slime-repl-return))
+
+(defun slime-repl-newline-and-indent ()
+ "Insert a newline, then indent the next line.
+Restrict the buffer from the prompt for indentation, to avoid being
+confused by strange characters (like unmatched quotes) appearing
+earlier in the buffer."
+ (interactive)
+ (save-restriction
+ (narrow-to-region slime-repl-prompt-start-mark (point-max))
+ (insert "\n")
+ (lisp-indent-line)))
+
+(defun slime-repl-delete-current-input ()
+ (delete-region slime-repl-input-start-mark slime-repl-input-end-mark))
+
+(defun slime-repl-kill-input ()
+ "Kill all text from the prompt to point."
+ (interactive)
+ (cond ((< (marker-position slime-repl-input-start-mark) (point))
+ (kill-region slime-repl-input-start-mark (point)))
+ ((= (point) (marker-position slime-repl-input-start-mark))
+ (slime-repl-delete-current-input))))
+
+(defun slime-repl-replace-input (string)
+ (slime-repl-delete-current-input)
+ (insert-and-inherit string))
+
+(defun slime-repl-input-line-beginning-position ()
+ (save-excursion
+ (goto-char slime-repl-input-start-mark)
+ (line-beginning-position)))
+
+(defvar slime-repl-clear-buffer-hook)
+
+(defun slime-repl-clear-buffer ()
+ "Delete the output generated by the Lisp process."
+ (interactive)
+ (set-marker slime-repl-last-input-start-mark nil)
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (slime-repl-input-line-beginning-position))
+ (goto-char slime-repl-input-start-mark))
+ (run-hooks 'slime-repl-clear-buffer-hook))
+
+(defun slime-repl-clear-output ()
+ "Delete the output inserted since the last input."
+ (interactive)
+ (let ((start (save-excursion
+ (slime-repl-previous-prompt)
+ (ignore-errors (forward-sexp))
+ (forward-line)
+ (point)))
+ (end (1- (slime-repl-input-line-beginning-position))))
+ (when (< start end)
+ (let ((inhibit-read-only t))
+ (delete-region start end)
+ (save-excursion
+ (goto-char start)
+ (insert ";;; output flushed"))))))
+
+(defun slime-indent-and-complete-symbol ()
+ "Indent the current line and perform symbol completion.
+First indent the line. If indenting doesn't move point, complete
+the symbol. If there's no symbol at the point, show the arglist
+for the most recently enclosed macro or function."
+ (interactive)
+ (let ((pos (point)))
+ (unless (get-text-property (line-beginning-position) 'slime-repl-prompt)
+ (lisp-indent-line))
+ (when (= pos (point))
+ (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t))
+ (slime-complete-symbol))
+ ((memq (char-before) '(?\t ?\ ))
+ (slime-echo-arglist))))))
+
+(defun slime-repl-set-package (package)
+ "Set the package of the REPL buffer to PACKAGE."
+ (interactive (list (slime-read-package-name
+ "Package: " (slime-pretty-find-buffer-package))))
+ (with-current-buffer (slime-output-buffer)
+ (let ((unfinished-input (slime-repl-current-input)))
+ (destructuring-bind (name prompt-string)
+ (slime-eval `(swank:set-package ,package))
+ (setf (slime-lisp-package) name)
+ (setf (slime-lisp-package-prompt-string) prompt-string)
+ (slime-repl-insert-prompt)
+ (insert unfinished-input)))))
+
+
+;;;;; History
+
+(defcustom slime-repl-wrap-history nil
+ "*T to wrap history around when the end is reached."
+ :type 'boolean
+ :group 'slime-repl)
+
+(make-variable-buffer-local
+ (defvar slime-repl-input-history '()
+ "History list of strings read from the REPL buffer."))
+
+(defun slime-repl-add-to-input-history (string)
+ "Add STRING to the input history.
+Empty strings and duplicates are ignored."
+ (unless (or (equal string "")
+ (equal string (car slime-repl-input-history)))
+ (push string slime-repl-input-history)))
+
+;; These two vars contain the state of the last history search. We
+;; only use them if `last-command' was 'slime-repl-history-replace,
+;; otherwise we reinitialize them.
+
+(defvar slime-repl-input-history-position -1
+ "Newer items have smaller indices.")
+
+(defvar slime-repl-history-pattern nil
+ "The regexp most recently used for finding input history.")
+
+(defun slime-repl-history-replace (direction &optional regexp delete-at-end-p)
+ "Replace the current input with the next line in DIRECTION.
+DIRECTION is 'forward' or 'backward' (in the history list).
+If REGEXP is non-nil, only lines matching REGEXP are considered.
+If DELETE-AT-END-P is non-nil then remove the string if the end of the
+history is reached."
+ (setq slime-repl-history-pattern regexp)
+ (let* ((min-pos -1)
+ (max-pos (length slime-repl-input-history))
+ (pos0 (cond ((slime-repl-history-search-in-progress-p)
+ slime-repl-input-history-position)
+ (t min-pos)))
+ (pos (slime-repl-position-in-history pos0 direction (or regexp "")))
+ (msg nil))
+ (cond ((and (< min-pos pos) (< pos max-pos))
+ (slime-repl-replace-input (nth pos slime-repl-input-history))
+ (setq msg (format "History item: %d" pos)))
+ ((not slime-repl-wrap-history)
+ (setq msg (cond ((= pos min-pos) "End of history")
+ ((= pos max-pos) "Beginning of history"))))
+ (slime-repl-wrap-history
+ (setq pos (if (= pos min-pos) max-pos min-pos))
+ (setq msg "Wrapped history")))
+ (when (or (<= pos min-pos) (<= max-pos pos))
+ (when regexp
+ (setq msg (concat msg "; no matching item")))
+ (when delete-at-end-p
+ (slime-repl-replace-input "")))
+ ;;(message "%s [%d %d %s]" msg start-pos pos regexp)
+ (message "%s%s" msg (cond ((not regexp) "")
+ (t (format "; current regexp: %s" regexp))))
+ (setq slime-repl-input-history-position pos)
+ (setq this-command 'slime-repl-history-replace)))
+
+(defun slime-repl-history-search-in-progress-p ()
+ (eq last-command 'slime-repl-history-replace))
+
+(defun slime-repl-terminate-history-search ()
+ (setq last-command this-command))
+
+(defun slime-repl-position-in-history (start-pos direction regexp)
+ "Return the position of the history item matching regexp.
+Return -1 resp. the length of the history if no item matches"
+ ;; Loop through the history list looking for a matching line
+ (let* ((step (ecase direction
+ (forward -1)
+ (backward 1)))
+ (history slime-repl-input-history)
+ (len (length history)))
+ (loop for pos = (+ start-pos step) then (+ pos step)
+ if (< pos 0) return -1
+ if (<= len pos) return len
+ if (string-match regexp (nth pos history)) return pos)))
+
+(defun slime-repl-previous-input ()
+ "Cycle backwards through input history.
+If the `last-command' was a history navigation command use the
+same search pattern for this command.
+Otherwise use the current input as search pattern."
+ (interactive)
+ (slime-repl-history-replace 'backward (slime-repl-history-pattern t) t))
+
+(defun slime-repl-next-input ()
+ "Cycle forwards through input history.
+See `slime-repl-previous-input'."
+ (interactive)
+ (slime-repl-history-replace 'forward (slime-repl-history-pattern t) t))
+
+(defun slime-repl-forward-input ()
+ "Cycle forwards through input history."
+ (interactive)
+ (slime-repl-history-replace 'forward (slime-repl-history-pattern) t))
+
+(defun slime-repl-backward-input ()
+ "Cycle backwards through input history."
+ (interactive)
+ (slime-repl-history-replace 'backward (slime-repl-history-pattern) t))
+
+(defun slime-repl-previous-matching-input (regexp)
+ (interactive "sPrevious element matching (regexp): ")
+ (slime-repl-terminate-history-search)
+ (slime-repl-history-replace 'backward regexp))
+
+(defun slime-repl-next-matching-input (regexp)
+ (interactive "sNext element matching (regexp): ")
+ (slime-repl-terminate-history-search)
+ (slime-repl-history-replace 'forward regexp))
+
+(defun slime-repl-history-pattern (&optional use-current-input)
+ "Return the regexp for the navigation commands."
+ (cond ((slime-repl-history-search-in-progress-p)
+ slime-repl-history-pattern)
+ (use-current-input
+ (let ((str (slime-repl-current-input)))
+ (cond ((string-match "^[ \n]*$" str) nil)
+ (t (concat "^" (regexp-quote str))))))
+ (t nil)))
+
+(defun slime-repl-delete-from-input-history (string)
+ "Delete STRING from the repl input history.
+
+When string is not provided then clear the current repl input and
+use it as an input. This is useful to get rid of unwanted repl
+history entries while navigating the repl history."
+ (interactive (list (slime-repl-current-input)))
+ (let ((merged-history
+ (slime-repl-merge-histories slime-repl-input-history
+ (slime-repl-read-history nil t))))
+ (setq slime-repl-input-history
+ (delete* string merged-history :test #'string=))
+ (slime-repl-save-history))
+ (slime-repl-delete-current-input))
+
+;;;;; Persistent History
+
+(defun slime-repl-merge-histories (old-hist new-hist)
+ "Merge entries from OLD-HIST and NEW-HIST."
+ ;; Newer items in each list are at the beginning.
+ (let* ((ht (make-hash-table :test #'equal))
+ (test (lambda (entry)
+ (or (gethash entry ht)
+ (progn (setf (gethash entry ht) t)
+ nil)))))
+ (append (remove-if test new-hist)
+ (remove-if test old-hist))))
+
+(defun slime-repl-load-history (&optional filename)
+ "Set the current SLIME REPL history.
+It can be read either from FILENAME or `slime-repl-history-file' or
+from a user defined filename."
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file)))
+ (setq slime-repl-input-history (slime-repl-read-history file t))))
+
+(defun slime-repl-read-history (&optional filename noerrer)
+ "Read and return the history from FILENAME.
+The default value for FILENAME is `slime-repl-history-file'.
+If NOERROR is true return and the file doesn't exits return nil."
+ (let ((file (or filename slime-repl-history-file)))
+ (cond ((not (file-readable-p file)) '())
+ (t (with-temp-buffer
+ (insert-file-contents file)
+ (read (current-buffer)))))))
+
+(defun slime-repl-read-history-filename ()
+ (read-file-name "Use SLIME REPL history from file: "
+ slime-repl-history-file))
+
+(defun slime-repl-save-merged-history (&optional filename)
+ "Read the history file, merge the current REPL history and save it.
+This tries to be smart in merging the history from the file and the
+current history in that it tries to detect the unique entries using
+`slime-repl-merge-histories'."
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file)))
+ (with-temp-message "saving history..."
+ (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t)
+ slime-repl-input-history)))
+ (slime-repl-save-history file hist)))))
+
+(defun slime-repl-save-history (&optional filename history)
+ "Simply save the current SLIME REPL history to a file.
+When SLIME is setup to always load the old history and one uses only
+one instance of slime all the time, there is no need to merge the
+files and this function is sufficient.
+
+When the list is longer than `slime-repl-history-size' it will be
+truncated. That part is untested, though!"
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file))
+ (hist (or history slime-repl-input-history)))
+ (unless (file-writable-p file)
+ (error (format "History file not writable: %s" file)))
+ (let ((hist (subseq hist 0 (min (length hist) slime-repl-history-size))))
+ ;;(message "saving %s to %s\n" hist file)
+ (with-temp-file file
+ (let ((cs slime-repl-history-file-coding-system)
+ (print-length nil) (print-level nil))
+ (setq buffer-file-coding-system cs)
+ (insert (format ";; -*- coding: %s -*-\n" cs))
+ (insert ";; History for SLIME REPL. Automatically written.\n"
+ ";; Edit only if you know what you're doing\n")
+ (prin1 (mapcar #'substring-no-properties hist) (current-buffer)))))))
+
+(defun slime-repl-save-all-histories ()
+ "Save the history in each repl buffer."
+ (dolist (b (buffer-list))
+ (with-current-buffer b
+ (when (eq major-mode 'slime-repl-mode)
+ (slime-repl-safe-save-merged-history)))))
+
+(defun slime-repl-safe-save-merged-history ()
+ (slime-repl-call-with-handler
+ #'slime-repl-save-merged-history
+ "%S while saving the history. Continue? "))
+
+(defun slime-repl-safe-load-history ()
+ (slime-repl-call-with-handler
+ #'slime-repl-load-history
+ "%S while loading the history. Continue? "))
+
+(defun slime-repl-call-with-handler (fun query)
+ "Call FUN in the context of an error handler.
+The handler will use qeuery to ask the use if the error should be ingored."
+ (condition-case err
+ (funcall fun)
+ (error
+ (if (y-or-n-p (format query (error-message-string err)))
+ nil
+ (signal (car err) (cdr err))))))
+
+
+;;;;; REPL Read Mode
+
+(define-key slime-repl-mode-map
+ (string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut)
+
+(define-minor-mode slime-repl-read-mode
+ "Mode the read input from Emacs
+\\{slime-repl-read-mode-map}"
+ nil
+ "[read]"
+ '(("\C-m" . slime-repl-return)
+ ([return] . slime-repl-return)
+ ("\C-c\C-b" . slime-repl-read-break)
+ ("\C-c\C-c" . slime-repl-read-break)))
+
+(make-variable-buffer-local
+ (defvar slime-read-string-threads nil))
+
+(make-variable-buffer-local
+ (defvar slime-read-string-tags nil))
+
+(defun slime-repl-read-string (thread tag)
+ (slime-switch-to-output-buffer)
+ (push thread slime-read-string-threads)
+ (push tag slime-read-string-tags)
+ (goto-char (point-max))
+ (slime-mark-output-end)
+ (slime-mark-input-start)
+ (slime-repl-read-mode 1))
+
+(defun slime-y-or-n-p (thread tag question)
+ (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question))))
+
+(defun slime-repl-return-string (string)
+ (slime-dispatch-event `(:emacs-return-string
+ ,(pop slime-read-string-threads)
+ ,(pop slime-read-string-tags)
+ ,string))
+ (slime-repl-read-mode -1))
+
+(defun slime-repl-read-break ()
+ (interactive)
+ (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads))))
+
+(defun slime-repl-abort-read (thread tag)
+ (with-current-buffer (slime-output-buffer)
+ (pop slime-read-string-threads)
+ (pop slime-read-string-tags)
+ (slime-repl-read-mode -1)
+ (message "Read aborted")))
+
+
+;;;;; REPL handlers
+
+(defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.))
+ symbol names handler one-liner)
+
+(defvar slime-repl-shortcut-table nil
+ "A list of slime-repl-shortcuts")
+
+(defvar slime-repl-shortcut-history '()
+ "History list of shortcut command names.")
+
+(defun slime-handle-repl-shortcut ()
+ (interactive)
+ (if (> (point) slime-repl-input-start-mark)
+ (insert (string slime-repl-shortcut-dispatch-char))
+ (let ((shortcut (slime-lookup-shortcut
+ (completing-read "Command: "
+ (slime-bogus-completion-alist
+ (slime-list-all-repl-shortcuts))
+ nil t nil
+ 'slime-repl-shortcut-history))))
+ (call-interactively (slime-repl-shortcut.handler shortcut)))))
+
+(defun slime-list-all-repl-shortcuts ()
+ (loop for shortcut in slime-repl-shortcut-table
+ append (slime-repl-shortcut.names shortcut)))
+
+(defun slime-lookup-shortcut (name)
+ (find-if (lambda (s) (member name (slime-repl-shortcut.names s)))
+ slime-repl-shortcut-table))
+
+(defmacro defslime-repl-shortcut (elisp-name names &rest options)
+ "Define a new repl shortcut. ELISP-NAME is a symbol specifying
+ the name of the interactive function to create, or NIL if no
+ function should be created. NAMES is a list of (full-name .
+ aliases). OPTIONS is an olist specifying the handler and the
+ help text."
+ `(progn
+ ,(when elisp-name
+ `(defun ,elisp-name ()
+ (interactive)
+ (call-interactively ,(second (assoc :handler options)))))
+ (let ((new-shortcut (make-slime-repl-shortcut
+ :symbol ',elisp-name
+ :names (list ,@names)
+ ,@(apply #'append options))))
+ (setq slime-repl-shortcut-table
+ (remove-if (lambda (s)
+ (member ',(car names) (slime-repl-shortcut.names s)))
+ slime-repl-shortcut-table))
+ (push new-shortcut slime-repl-shortcut-table)
+ ',elisp-name)))
+
+(defun slime-list-repl-short-cuts ()
+ (interactive)
+ (slime-with-output-to-temp-buffer ("*slime-repl-help*") nil
+ (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string<
+ :key (lambda (x)
+ (car (slime-repl-shortcut.names x))))))
+ (dolist (shortcut table)
+ (let ((names (slime-repl-shortcut.names shortcut)))
+ (insert (pop names)) ;; first print the "full" name
+ (when names
+ ;; we also have aliases
+ (insert " (aka ")
+ (while (cdr names)
+ (insert (pop names) ", "))
+ (insert (car names) ")"))
+ (insert "\n " (slime-repl-shortcut.one-liner shortcut)
+ "\n"))))))
+
+(defun slime-save-some-lisp-buffers ()
+ (if slime-repl-only-save-lisp-buffers
+ (save-some-buffers nil (lambda ()
+ (and (memq major-mode slime-lisp-modes)
+ (not (null buffer-file-name)))))
+ (save-some-buffers)))
+
+(defslime-repl-shortcut slime-repl-shortcut-help ("help" "?")
+ (:handler 'slime-list-repl-short-cuts)
+ (:one-liner "Display the help."))
+
+(defslime-repl-shortcut nil ("change-directory" "!d" "cd")
+ (:handler 'slime-set-default-directory)
+ (:one-liner "Change the current directory."))
+
+(defslime-repl-shortcut nil ("pwd")
+ (:handler (lambda ()
+ (interactive)
+ (let ((dir (slime-eval `(swank:default-directory))))
+ (message "Directory %s" dir))))
+ (:one-liner "Show the current directory."))
+
+(defslime-repl-shortcut slime-repl-push-directory
+ ("push-directory" "+d" "pushd")
+ (:handler (lambda (directory)
+ (interactive
+ (list (read-directory-name
+ "Push directory: "
+ (slime-eval '(swank:default-directory))
+ nil nil "")))
+ (push (slime-eval '(swank:default-directory))
+ slime-repl-directory-stack)
+ (slime-set-default-directory directory)))
+ (:one-liner "Save the current directory and set it to a new one."))
+
+(defslime-repl-shortcut slime-repl-pop-directory
+ ("pop-directory" "-d" "popd")
+ (:handler (lambda ()
+ (interactive)
+ (if (null slime-repl-directory-stack)
+ (message "Directory stack is empty.")
+ (slime-set-default-directory
+ (pop slime-repl-directory-stack)))))
+ (:one-liner "Restore the last saved directory."))
+
+(defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in")
+ (:handler 'slime-repl-set-package)
+ (:one-liner "Change the current package."))
+
+(defslime-repl-shortcut slime-repl-push-package ("push-package" "+p")
+ (:handler (lambda (package)
+ (interactive (list (slime-read-package-name "Package: ")))
+ (push (slime-lisp-package) slime-repl-package-stack)
+ (slime-repl-set-package package)))
+ (:one-liner "Save the current package and set it to a new one."))
+
+(defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p")
+ (:handler (lambda ()
+ (interactive)
+ (if (null slime-repl-package-stack)
+ (message "Package stack is empty.")
+ (slime-repl-set-package
+ (pop slime-repl-package-stack)))))
+ (:one-liner "Restore the last saved package."))
+
+(defslime-repl-shortcut slime-repl-resend ("resend-form")
+ (:handler (lambda ()
+ (interactive)
+ (insert (car slime-repl-input-history))
+ (insert "\n")
+ (slime-repl-send-input)))
+ (:one-liner "Resend the last form."))
+
+(defslime-repl-shortcut slime-repl-disconnect ("disconnect")
+ (:handler 'slime-disconnect)
+ (:one-liner "Disconnect all connections."))
+
+(defslime-repl-shortcut slime-repl-sayoonara ("sayoonara")
+ (:handler (lambda ()
+ (interactive)
+ (when (slime-connected-p)
+ (slime-quit-lisp))
+ (slime-kill-all-buffers)))
+ (:one-liner "Quit all Lisps and close all SLIME buffers."))
+
+(defslime-repl-shortcut slime-repl-quit ("quit")
+ (:handler 'slime-quit-lisp)
+ (:one-liner "Quit the current Lisp."))
+
+(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!")
+ (:handler (lambda (name value)
+ (interactive (list (slime-read-symbol-name "Name (symbol): " t)
+ (slime-read-from-minibuffer "Value: " "*")))
+ (insert "(cl:defparameter " name " " value
+ " \"REPL generated global variable.\")")
+ (slime-repl-send-input t)))
+ (:one-liner "Define a new global, special, variable."))
+
+(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl")
+ (:handler (lambda (filename)
+ (interactive (list (expand-file-name
+ (read-file-name "File: " nil nil nil nil))))
+ (slime-save-some-lisp-buffers)
+ (slime-eval-async
+ `(swank:compile-file-if-needed
+ ,(slime-to-lisp-filename filename) t)
+ (slime-make-compilation-finished-continuation (current-buffer)))))
+ (:one-liner "Compile (if neccessary) and load a lisp file."))
+
+(defslime-repl-shortcut nil ("restart-inferior-lisp")
+ (:handler 'slime-restart-inferior-lisp)
+ (:one-liner "Restart *inferior-lisp* and reconnect SLIME."))
+
+(defun slime-restart-inferior-lisp ()
+ (interactive)
+ (assert (slime-inferior-process) () "No inferior lisp process")
+ (slime-eval-async '(swank:quit-lisp))
+ (set-process-filter (slime-connection) nil)
+ (set-process-sentinel (slime-connection) 'slime-restart-sentinel))
+
+(defun slime-restart-sentinel (process message)
+ "Restart the inferior lisp process.
+Also rearrange windows."
+ (assert (process-status process) 'closed)
+ (let* ((proc (slime-inferior-process process))
+ (args (slime-inferior-lisp-args proc))
+ (buffer (buffer-name (process-buffer proc)))
+ (buffer-window (get-buffer-window buffer))
+ (new-proc (slime-start-lisp (plist-get args :program)
+ (plist-get args :program-args)
+ nil
+ buffer))
+ (repl-buffer (slime-repl-buffer nil process))
+ (repl-window (and repl-buffer (get-buffer-window repl-buffer))))
+ (slime-net-close process)
+ (slime-inferior-connect new-proc args)
+ (cond ((and repl-window (not buffer-window))
+ (set-window-buffer repl-window buffer)
+ (select-window repl-window))
+ (repl-window
+ (select-window repl-window))
+ (t
+ (pop-to-buffer buffer)))
+ (switch-to-buffer buffer)
+ (goto-char (point-max))))
+
+
+;;;;; Cleanup after a quit
+
+(defun slime-kill-all-buffers ()
+ "Kill all the slime related buffers. This is only used by the
+ repl command sayoonara."
+ (dolist (buf (buffer-list))
+ (when (or (string= (buffer-name buf) slime-event-buffer-name)
+ (string-match "^\\*inferior-lisp*" (buffer-name buf))
+ (string-match "^\\*slime-repl .*\\*$" (buffer-name buf))
+ (string-match "^\\*sldb .*\\*$" (buffer-name buf))
+ (string-match "^\\*SLIME.*\\*$" (buffer-name buf)))
+ (kill-buffer buf))))
+
+
+;;;; Compilation and the creation of compiler-note annotations
+
+(defvar slime-highlight-compiler-notes t
+ "*When non-nil annotate buffers with compilation notes etc.")
+
+(defcustom slime-display-compilation-output t
+ "Display the REPL buffer before compiling files."
+ :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+ :group 'slime-mode)
+
+(defvar slime-before-compile-functions nil
+ "A list of function called before compiling a buffer or region.
+The function receive two arguments: the beginning and the end of the
+region that will be compiled.")
+
+(defcustom slime-compilation-finished-hook 'slime-maybe-list-compiler-notes
+ "Hook called with a list of compiler notes after a compilation."
+ :group 'slime-mode
+ :type 'hook
+ :options '(slime-maybe-list-compiler-notes
+ slime-list-compiler-notes
+ slime-maybe-show-xrefs-for-notes))
+
+(defcustom slime-goto-first-note-after-compilation nil
+ "When T next-note will always goto to the first note in a
+final, no matter where the point is."
+ :group 'slime-mode
+ :type 'boolean)
+
+(defun slime-compile-and-load-file ()
+ "Compile and load the buffer's file and highlight compiler notes.
+
+Each source location that is the subject of a compiler note is
+underlined and annotated with the relevant information. The commands
+`slime-next-note' and `slime-previous-note' can be used to navigate
+between compiler notes and to display their full details."
+ (interactive)
+ (slime-compile-file t))
+
+(defun slime-compile-file (&optional load)
+ "Compile current buffer's file and highlight resulting compiler notes.
+
+See `slime-compile-and-load-file' for further details."
+ (interactive)
+ ;;(unless (memq major-mode slime-lisp-modes)
+ ;; (error "Only valid in lisp-mode"))
+ (check-parens)
+ (unless buffer-file-name
+ (error "Buffer %s is not associated with a file." (buffer-name)))
+ (when (and (buffer-modified-p)
+ (y-or-n-p (format "Save file %s? " (buffer-file-name))))
+ (save-buffer))
+ (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max))
+ (let ((file (slime-to-lisp-filename (buffer-file-name))))
+ (slime-insert-transcript-delimiter (format "Compile file %s" file))
+ (when slime-display-compilation-output
+ (slime-display-output-buffer))
+ (slime-eval-async
+ `(swank:compile-file-for-emacs ,file ,(if load t nil))
+ (slime-rcurry #'slime-compilation-finished (current-buffer)))
+ (message "Compiling %s..." file)))
+
+(defun slime-compile-defun ()
+ "Compile the current toplevel form."
+ (interactive)
+ (apply #'slime-compile-region (slime-region-for-defun-at-point)))
+
+(defun slime-compile-region (start end)
+ "Compile the region."
+ (interactive "r")
+ (run-hook-with-args 'slime-before-compile-functions start end)
+ (slime-compile-string (buffer-substring-no-properties start end) start))
+
+(defun slime-compile-string (string start-offset)
+ (slime-eval-async
+ `(swank:compile-string-for-emacs
+ ,string
+ ,(buffer-name)
+ ,start-offset
+ ,(if (buffer-file-name) (file-name-directory (buffer-file-name))))
+ (slime-make-compilation-finished-continuation (current-buffer))))
+
+(defun slime-note-count-string (severity count &optional suppress-if-zero)
+ (cond ((and (zerop count) suppress-if-zero)
+ "")
+ (t (format "%2d %s%s " count severity (if (= count 1) "" "s")))))
+
+(defun slime-show-note-counts (notes &optional secs)
+ (let ((nerrors 0) (nwarnings 0) (nstyle-warnings 0) (nnotes 0))
+ (dolist (note notes)
+ (ecase (slime-note.severity note)
+ ((:error :read-error) (incf nerrors))
+ (:warning (incf nwarnings))
+ (:style-warning (incf nstyle-warnings))
+ (:note (incf nnotes))))
+ (message "Compilation finished:%s%s%s%s%s"
+ (slime-note-count-string "error" nerrors)
+ (slime-note-count-string "warning" nwarnings)
+ (slime-note-count-string "style-warning" nstyle-warnings t)
+ (slime-note-count-string "note" nnotes)
+ (if secs (format "[%s secs]" secs) ""))))
+
+(defun slime-xrefs-for-notes (notes)
+ (let ((xrefs))
+ (dolist (note notes)
+ (let* ((location (getf note :location))
+ (fn (cadr (assq :file (cdr location))))
+ (file (assoc fn xrefs))
+ (node
+ (cons (format "%s: %s"
+ (getf note :severity)
+ (slime-one-line-ify (getf note :message)))
+ location)))
+ (when fn
+ (if file
+ (push node (cdr file))
+ (setf xrefs (acons fn (list node) xrefs))))))
+ xrefs))
+
+(defun slime-one-line-ify (string)
+ "Return a single-line version of STRING.
+Each newlines and following indentation is replaced by a single space."
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (re-search-forward "\n[\n \t]*" nil t)
+ (replace-match " "))
+ (buffer-string)))
+
+(defun slime-compilation-finished (result buffer &optional emacs-snapshot)
+ (let ((notes (slime-compiler-notes)))
+ (with-current-buffer buffer
+ (setf slime-compilation-just-finished t)
+ (destructuring-bind (result secs) result
+ (slime-show-note-counts notes secs)
+ (when slime-highlight-compiler-notes
+ (slime-highlight-notes notes))))
+ (run-hook-with-args 'slime-compilation-finished-hook notes emacs-snapshot)))
+
+(defun slime-make-compilation-finished-continuation (current-buffer &optional emacs-snapshot)
+ (lexical-let ((buffer current-buffer) (snapshot emacs-snapshot))
+ (lambda (result)
+ (slime-compilation-finished result buffer snapshot))))
+
+(defun slime-highlight-notes (notes)
+ "Highlight compiler notes, warnings, and errors in the buffer."
+ (interactive (list (slime-compiler-notes)))
+ (with-temp-message "Highlighting notes..."
+ (save-excursion
+ (save-restriction
+ (widen) ; highlight notes on the whole buffer
+ (slime-remove-old-overlays)
+ (mapc #'slime-overlay-note (slime-merge-notes-for-display notes))))))
+
+(defun slime-compiler-notes ()
+ "Return all compiler notes, warnings, and errors."
+ (slime-eval `(swank:compiler-notes-for-emacs)))
+
+(defun slime-remove-old-overlays ()
+ "Delete the existing Slime overlays in the current buffer."
+ (dolist (buffer (slime-filter-buffers (lambda () slime-mode)))
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (widen) ; remove overlays within the whole buffer.
+ (goto-char (point-min))
+ (while (not (eobp))
+ (dolist (o (overlays-at (point)))
+ (when (overlay-get o 'slime)
+ (delete-overlay o)))
+ (goto-char (next-overlay-change (point)))))))))
+
+(defun slime-filter-buffers (predicate)
+ "Return a list of where PREDICATE returns true.
+PREDICATE is executed in the buffer to test."
+ (remove-if-not (lambda (%buffer)
+ (with-current-buffer %buffer
+ (funcall predicate)))
+ (buffer-list)))
+
+
+;;;;; Merging together compiler notes in the same location.
+
+(defun slime-merge-notes-for-display (notes)
+ "Merge together notes that refer to the same location.
+This operation is \"lossy\" in the broad sense but not for display purposes."
+ (mapcar #'slime-merge-notes
+ (slime-group-similar 'slime-notes-in-same-location-p notes)))
+
+(defun slime-merge-notes (notes)
+ "Merge NOTES together. Keep the highest severity, concatenate the messages."
+ (let* ((new-severity (reduce #'slime-most-severe notes
+ :key #'slime-note.severity))
+ (new-message (mapconcat #'slime-note.short-message notes "\n")))
+ (let ((new-note (copy-list (car notes))))
+ (setf (getf new-note :message) new-message)
+ (setf (getf new-note :severity) new-severity)
+ new-note)))
+
+;; XXX: unused function
+(defun slime-intersperse (element list)
+ "Intersperse ELEMENT between each element of LIST."
+ (if (null list)
+ '()
+ (cons (car list)
+ (mapcan (lambda (x) (list element x)) (cdr list)))))
+
+(defun slime-notes-in-same-location-p (a b)
+ (equal (slime-note.location a) (slime-note.location b)))
+
+(defun slime-group-similar (similar-p list)
+ "Return the list of lists of 'similar' adjacent elements of LIST.
+The function SIMILAR-P is used to test for similarity.
+The order of the input list is preserved."
+ (if (null list)
+ nil
+ (let ((accumulator (list (list (car list)))))
+ (dolist (x (cdr list))
+ (if (funcall similar-p x (caar accumulator))
+ (push x (car accumulator))
+ (push (list x) accumulator)))
+ (reverse (mapcar #'reverse accumulator)))))
+
+
+;;;;; Compiler notes list
+
+(defun slime-maybe-show-xrefs-for-notes (&optional notes emacs-snapshot)
+ "Show the compiler notes NOTES if they come from more than one file."
+ (let* ((notes (or notes (slime-compiler-notes)))
+ (xrefs (slime-xrefs-for-notes notes)))
+ (when (slime-length> xrefs 1) ; >1 file
+ (slime-show-xrefs
+ xrefs 'definition "Compiler notes" (slime-current-package)
+ emacs-snapshot))))
+
+(defun slime-note-has-location-p (note)
+ (not (eq ':error (car (slime-note.location note)))))
+
+(defun slime-maybe-list-compiler-notes (notes &optional emacs-snapshot)
+ "Show the compiler notes if appropriate."
+ ;; don't pop up a buffer if all notes are already annotated in the
+ ;; buffer itself
+ (unless (every #'slime-note-has-location-p notes)
+ (slime-list-compiler-notes notes emacs-snapshot)))
+
+(defun slime-list-compiler-notes (notes &optional emacs-snapshot)
+ "Show the compiler notes NOTES in tree view."
+ (interactive (list (slime-compiler-notes)))
+ (with-temp-message "Preparing compiler note tree..."
+ (with-current-buffer
+ (slime-get-temp-buffer-create "*compiler notes*"
+ :mode 'slime-compiler-notes-mode
+ :emacs-snapshot emacs-snapshot)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (when (null notes)
+ (insert "[no notes]"))
+ (dolist (tree (slime-compiler-notes-to-tree notes))
+ (slime-tree-insert tree "")
+ (insert "\n")))
+ (setq buffer-read-only t)
+ (goto-char (point-min)))))
+
+(defun slime-alistify (list key test)
+ "Partition the elements of LIST into an alist.
+KEY extracts the key from an element and TEST is used to compare keys."
+ (declare (type function key))
+ (let ((alist '()))
+ (dolist (e list)
+ (let* ((k (funcall key e))
+ (probe (assoc* k alist :test test)))
+ (if probe
+ (push e (cdr probe))
+ (push (cons k (list e)) alist))))
+ ;; Put them back in order.
+ (loop for (key . value) in alist
+ collect (cons key (reverse value)))))
+
+(defun slime-note.severity (note)
+ (plist-get note :severity))
+
+(defun slime-note.message (note)
+ (plist-get note :message))
+
+(defun slime-note.short-message (note)
+ (or (plist-get note :short-message)
+ (plist-get note :message)))
+
+(defun slime-note.location (note)
+ (plist-get note :location))
+
+(defun slime-severity-label (severity)
+ (ecase severity
+ (:note "Notes")
+ (:warning "Warnings")
+ (:error "Errors")
+ (:read-error "Read Errors")
+ (:style-warning "Style Warnings")))
+
+(defvar slime-tree-printer 'slime-tree-default-printer)
+
+(defun slime-tree-for-note (note)
+ (make-slime-tree :item (slime-note.message note)
+ :plist (list 'note note)
+ :print-fn slime-tree-printer))
+
+(defun slime-tree-for-severity (severity notes collapsed-p)
+ (make-slime-tree :item (format "%s (%d)"
+ (slime-severity-label severity)
+ (length notes))
+ :kids (mapcar #'slime-tree-for-note notes)
+ :collapsed-p collapsed-p))
+
+(defun slime-compiler-notes-to-tree (notes)
+ (let* ((alist (slime-alistify notes #'slime-note.severity #'eq))
+ (collapsed-p (slime-length> alist 1)))
+ (loop for (severity . notes) in alist
+ collect (slime-tree-for-severity severity notes
+ collapsed-p))))
+
+(defvar slime-compiler-notes-mode-map)
+
+(define-derived-mode slime-compiler-notes-mode fundamental-mode
+ "Compiler Notes"
+ "\\<slime-compiler-notes-mode-map>\
+\\{slime-compiler-notes-mode-map}"
+ (slime-set-truncate-lines))
+
+(slime-define-keys slime-compiler-notes-mode-map
+ ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details)
+ ([return] 'slime-compiler-notes-default-action-or-show-details)
+ ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse)
+ ("q" 'slime-temp-buffer-quit))
+
+(defun slime-compiler-notes-default-action-or-show-details/mouse (event)
+ "Invoke the action pointed at by the mouse, or show details."
+ (interactive "e")
+ (destructuring-bind (mouse-2 (w pos &rest _) &rest __) event
+ (save-excursion
+ (goto-char pos)
+ (let ((fn (get-text-property (point)
+ 'slime-compiler-notes-default-action)))
+ (if fn (funcall fn) (slime-compiler-notes-show-details))))))
+
+(defun slime-compiler-notes-default-action-or-show-details ()
+ "Invoke the action at point, or show details."
+ (interactive)
+ (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action)))
+ (if fn (funcall fn) (slime-compiler-notes-show-details))))
+
+(defun slime-compiler-notes-show-details ()
+ (interactive)
+ (let* ((tree (slime-tree-at-point))
+ (note (plist-get (slime-tree.plist tree) 'note))
+ (inhibit-read-only t))
+ (cond ((not (slime-tree-leaf-p tree))
+ (slime-tree-toggle tree))
+ (t
+ (slime-show-source-location (slime-note.location note) t)))))
+
+
+;;;;;; Tree Widget
+
+(defstruct (slime-tree (:conc-name slime-tree.))
+ item
+ (print-fn #'slime-tree-default-printer :type function)
+ (kids '() :type list)
+ (collapsed-p t :type boolean)
+ (prefix "" :type string)
+ (start-mark nil)
+ (end-mark nil)
+ (plist '() :type list))
+
+(defun slime-tree-leaf-p (tree)
+ (not (slime-tree.kids tree)))
+
+(defun slime-tree-default-printer (tree)
+ (princ (slime-tree.item tree) (current-buffer)))
+
+(defun slime-tree-decoration (tree)
+ (cond ((slime-tree-leaf-p tree) "-- ")
+ ((slime-tree.collapsed-p tree) "[+] ")
+ (t "-+ ")))
+
+(defun slime-tree-insert-list (list prefix)
+ "Insert a list of trees."
+ (loop for (elt . rest) on list
+ do (cond (rest
+ (insert prefix " |")
+ (slime-tree-insert elt (concat prefix " |"))
+ (insert "\n"))
+ (t
+ (insert prefix " `")
+ (slime-tree-insert elt (concat prefix " "))))))
+
+(defun slime-tree-insert-decoration (tree)
+ (insert (slime-tree-decoration tree)))
+
+(defun slime-tree-indent-item (start end prefix)
+ "Insert PREFIX at the beginning of each but the first line.
+This is used for labels spanning multiple lines."
+ (save-excursion
+ (goto-char end)
+ (beginning-of-line)
+ (while (< start (point))
+ (insert-before-markers prefix)
+ (forward-line -1))))
+
+(defun slime-tree-insert (tree prefix)
+ "Insert TREE prefixed with PREFIX at point."
+ (with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree
+ (let ((line-start (line-beginning-position)))
+ (setf start-mark (point-marker))
+ (slime-tree-insert-decoration tree)
+ (funcall print-fn tree)
+ (slime-tree-indent-item start-mark (point) (concat prefix " "))
+ (add-text-properties line-start (point) (list 'slime-tree tree))
+ (set-marker-insertion-type start-mark t)
+ (when (and kids (not collapsed-p))
+ (terpri (current-buffer))
+ (slime-tree-insert-list kids prefix))
+ (setf (slime-tree.prefix tree) prefix)
+ (setf end-mark (point-marker)))))
+
+(defun slime-tree-at-point ()
+ (cond ((get-text-property (point) 'slime-tree))
+ (t (error "No tree at point"))))
+
+(defun slime-tree-delete (tree)
+ "Delete the region for TREE."
+ (delete-region (slime-tree.start-mark tree)
+ (slime-tree.end-mark tree)))
+
+(defun slime-tree-toggle (tree)
+ "Toggle the visibility of TREE's children."
+ (with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree
+ (setf collapsed-p (not collapsed-p))
+ (slime-tree-delete tree)
+ (insert-before-markers " ") ; move parent's end-mark
+ (backward-char 1)
+ (slime-tree-insert tree prefix)
+ (delete-char 1)
+ (goto-char start-mark)))
+
+
+;;;;; Adding a single compiler note
+
+(defun slime-overlay-note (note)
+ "Add a compiler note to the buffer as an overlay.
+If an appropriate overlay for a compiler note in the same location
+already exists then the new information is merged into it. Otherwise a
+new overlay is created."
+ (multiple-value-bind (start end) (slime-choose-overlay-region note)
+ (when start
+ (goto-char start)
+ (let ((severity (plist-get note :severity))
+ (message (plist-get note :message))
+ (overlay (slime-note-at-point)))
+ (if overlay
+ (slime-merge-note-into-overlay overlay severity message)
+ (slime-create-note-overlay note start end severity message))))))
+
+(defun slime-create-note-overlay (note start end severity message)
+ "Create an overlay representing a compiler note.
+The overlay has several properties:
+ FACE - to underline the relevant text.
+ SEVERITY - for future reference, :NOTE, :STYLE-WARNING, :WARNING, or :ERROR.
+ MOUSE-FACE - highlight the note when the mouse passes over.
+ HELP-ECHO - a string describing the note, both for future reference
+ and for display as a tooltip (due to the special
+ property name)."
+ (let ((overlay (make-overlay start end)))
+ (flet ((putp (name value) (overlay-put overlay name value)))
+ (putp 'slime note)
+ (putp 'face (slime-severity-face severity))
+ (putp 'severity severity)
+ (unless (slime-emacs-20-p)
+ (putp 'mouse-face 'highlight))
+ (putp 'help-echo message)
+ overlay)))
+
+;; XXX Obsolete due to `slime-merge-notes-for-display' doing the
+;; work already -- unless we decide to put several sets of notes on a
+;; buffer without clearing in between, which only this handles.
+(defun slime-merge-note-into-overlay (overlay severity message)
+ "Merge another compiler note into an existing overlay.
+The help text describes both notes, and the highest of the severities
+is kept."
+ (flet ((putp (name value) (overlay-put overlay name value))
+ (getp (name) (overlay-get overlay name)))
+ (putp 'severity (slime-most-severe severity (getp 'severity)))
+ (putp 'face (slime-severity-face (getp 'severity)))
+ (putp 'help-echo (concat (getp 'help-echo) "\n" message))))
+
+(defun slime-choose-overlay-region (note)
+ "Choose the start and end points for an overlay over NOTE.
+If the location's sexp is a list spanning multiple lines, then the
+region around the first element is used.
+Return nil if there's no useful source location."
+ (let ((location (slime-note.location note)))
+ (when location
+ (destructure-case location
+ ((:error _) _ nil) ; do nothing
+ ((:location file pos _hints)
+ (cond ((eq (car file) ':source-form) nil)
+ (t
+ (destructure-case pos
+ ((:position pos &optional alignp)
+ (if (eq (slime-note.severity note) :read-error)
+ (values pos (1+ pos))
+ (slime-choose-overlay-for-sexp location)))
+ (t
+ (slime-choose-overlay-for-sexp location))))))))))
+
+(defun slime-choose-overlay-for-sexp (location)
+ (slime-goto-source-location location)
+ (skip-chars-forward "'#`")
+ (let ((start (point)))
+ (ignore-errors (slime-forward-sexp))
+ (if (slime-same-line-p start (point))
+ (values start (point))
+ (values (1+ start)
+ (progn (goto-char (1+ start))
+ (ignore-errors (forward-sexp 1))
+ (point))))))
+
+(defun slime-same-line-p (pos1 pos2)
+ "Return t if buffer positions POS1 and POS2 are on the same line."
+ (save-excursion (goto-char (min pos1 pos2))
+ (<= (max pos1 pos2) (line-end-position))))
+
+(defun slime-severity-face (severity)
+ "Return the name of the font-lock face representing SEVERITY."
+ (ecase severity
+ (:error 'slime-error-face)
+ (:read-error 'slime-error-face)
+ (:warning 'slime-warning-face)
+ (:style-warning 'slime-style-warning-face)
+ (:note 'slime-note-face)))
+
+(defun slime-most-severe (sev1 sev2)
+ "Return the most servere of two conditions.
+Severity is ordered as :NOTE < :STYLE-WARNING < :WARNING < :ERROR."
+ ; Well, not exactly Smullyan..
+ (let ((order '(:note :style-warning :warning :error :read-error)))
+ (if (>= (position sev1 order)
+ (position sev2 order))
+ sev1
+ sev2)))
+
+;; XXX: unused function
+(defun slime-visit-source-path (source-path)
+ "Visit a full source path including the top-level form."
+ (goto-char (point-min))
+ (slime-forward-source-path source-path))
+
+(defun slime-forward-positioned-source-path (source-path)
+ "Move forward through a sourcepath from a fixed position.
+The point is assumed to already be at the outermost sexp, making the
+first element of the source-path redundant."
+ (ignore-errors
+ (slime-forward-sexp)
+ (beginning-of-defun))
+ (when-let (source-path (cdr source-path))
+ (down-list 1)
+ (slime-forward-source-path source-path)))
+
+(defun slime-forward-source-path (source-path)
+ (let ((origin (point)))
+ (condition-case nil
+ (progn
+ (loop for (count . more) on source-path
+ do (progn
+ (slime-forward-sexp count)
+ (when more (down-list 1))))
+ ;; Align at beginning
+ (slime-forward-sexp)
+ (beginning-of-sexp))
+ (error (goto-char origin)))))
+
+(defun slime-filesystem-toplevel-directory ()
+ ;; Windows doesn't have a true toplevel root directory, and all
+ ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs
+ ;; perspective anyway.
+ (if (memq system-type '(ms-dos windows-nt))
+ ""
+ (file-name-as-directory "/")))
+
+(defun slime-file-name-merge-source-root (target-filename buffer-filename)
+ "Returns a filename where the source root directory of TARGET-FILENAME
+is replaced with the source root directory of BUFFER-FILENAME.
+
+If no common source root could be determined, return NIL.
+
+E.g. (slime-file-name-merge-source-root
+ \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\"
+ \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\")
+
+ ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\"
+"
+ (let ((target-dirs (slime-split-string (file-name-directory target-filename) "/" t))
+ (buffer-dirs (slime-split-string (file-name-directory buffer-filename) "/" t)))
+ ;; Starting from the end, we look if one of the TARGET-DIRS exists
+ ;; in BUFFER-FILENAME---if so, it and everything left from that dirname
+ ;; is considered to be the source root directory of BUFFER-FILENAME.
+ (loop with target-suffix-dirs = nil
+ with buffer-dirs* = (reverse buffer-dirs)
+ with target-dirs* = (reverse target-dirs)
+ for target-dir in target-dirs*
+ do (flet ((concat-dirs (dirs)
+ (apply #'concat (mapcar #'file-name-as-directory dirs))))
+ (let ((pos (position target-dir buffer-dirs* :test #'equal)))
+ (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME?
+ (push target-dir target-suffix-dirs)
+ (let* ((target-suffix (concat-dirs target-suffix-dirs)) ; PUSH reversed for us!
+ (buffer-root (concat-dirs (reverse (nthcdr pos buffer-dirs*)))))
+ (return (concat (slime-filesystem-toplevel-directory)
+ buffer-root
+ target-suffix
+ (file-name-nondirectory target-filename))))))))))
+
+(defun slime-highlight-differences-in-dirname (base-dirname contrast-dirname)
+ "Returns a copy of BASE-DIRNAME where all differences between
+BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a
+highlighting face."
+ (setq base-dirname (file-name-as-directory base-dirname))
+ (setq contrast-dirname (file-name-as-directory contrast-dirname))
+ (flet ((insert-dir (dirname)
+ (insert (file-name-as-directory dirname)))
+ (insert-dir/propzd (dirname)
+ (slime-insert-propertized '(face highlight) dirname)
+ (insert "/"))) ; Not exactly portable (to VMS...)
+ (let ((base-dirs (slime-split-string base-dirname "/" t))
+ (contrast-dirs (slime-split-string contrast-dirname "/" t)))
+ (with-temp-buffer
+ (loop initially (insert (slime-filesystem-toplevel-directory))
+ for base-dir in base-dirs do
+ (let ((pos (position base-dir contrast-dirs :test #'equal)))
+ (if (not pos)
+ (insert-dir/propzd base-dir)
+ (progn (insert-dir base-dir)
+ (setq contrast-dirs (nthcdr (1+ pos) contrast-dirs))))))
+ (buffer-substring (point-min) (point-max))))))
+
+(defvar slime-warn-when-possibly-tricked-by-M-. t
+ "When working on multiple source trees simultaneously, the way
+`slime-edit-definition' (M-.) works can sometimes be confusing:
+
+`M-.' visits locations that are present in the current Lisp image,
+which works perfectly well as long as the image reflects the source
+tree that one is currently looking at.
+
+In the other case, however, one can easily end up visiting a file
+in a different source root directory (the one corresponding to
+the Lisp image), and is thus easily tricked to modify the wrong
+source files---which can lead to quite some stressfull cursing.
+
+If this variable is T, a warning message is issued to raise the
+user's attention whenever `M-.' is about opening a file in a
+different source root that also exists in the source root
+directory of the user's current buffer.
+
+There's no guarantee that all possible cases are covered, but
+if you encounter such a warning, it's a strong indication that
+you should check twice before modifying.")
+
+(defun slime-maybe-warn-for-different-source-root (target-filename buffer-filename)
+ (when slime-warn-when-possibly-tricked-by-M-.
+ (let ((guessed-target (slime-file-name-merge-source-root target-filename
+ buffer-filename)))
+ (when (and guessed-target
+ (not (equal guessed-target target-filename))
+ (file-exists-p guessed-target))
+ (slime-message "Attention: This is `%s'."
+ (concat (slime-highlight-differences-in-dirname
+ (file-name-directory target-filename)
+ (file-name-directory guessed-target))
+ (file-name-nondirectory target-filename)))))))
+
+
+(defun slime-goto-location-buffer (buffer)
+ (flet ((file-truename-safe (filename) (and filename (file-truename filename))))
+ (destructure-case buffer
+ ((:file filename)
+ (let ((target-filename (file-truename-safe (slime-from-lisp-filename filename)))
+ (buffer-filename (file-truename-safe (buffer-file-name))))
+ (when buffer-filename
+ (slime-maybe-warn-for-different-source-root target-filename buffer-filename))
+ (unless (and buffer-filename (string= buffer-filename target-filename))
+ (set-buffer (find-file-noselect target-filename t))))
+ (goto-char (point-min)))
+ ((:buffer buffer-name)
+ (let ((old-buffer-filename (file-truename-safe (buffer-file-name)))
+ (target-buffer-filename (file-truename-safe
+ (buffer-file-name (get-buffer buffer-name)))))
+ (when (and target-buffer-filename old-buffer-filename)
+ (slime-maybe-warn-for-different-source-root target-buffer-filename
+ old-buffer-filename)))
+ (set-buffer buffer-name)
+ (goto-char (point-min)))
+ ((:source-form string)
+ (set-buffer (get-buffer-create "*SLIME Source Form*"))
+ (erase-buffer)
+ (lisp-mode)
+ (insert string)
+ (goto-char (point-min)))
+ ((:zip file entry)
+ (require 'arc-mode)
+ (set-buffer (find-file-noselect file t))
+ (goto-char (point-min))
+ (re-search-forward (concat " " entry "$"))
+ (let ((buffer (save-window-excursion
+ (archive-extract)
+ (current-buffer))))
+ (set-buffer buffer)
+ (goto-char (point-min)))))))
+
+(defun slime-goto-location-position (position)
+ (save-restriction-if-possible ; try to keep restriction if possible.
+ (widen)
+ (destructure-case position
+ ((:position pos &optional align-p)
+ (goto-char pos)
+ (when align-p
+ (slime-forward-sexp)
+ (beginning-of-sexp)))
+ ((:line start &optional column)
+ (goto-line start)
+ (cond (column (move-to-column column))
+ (t (skip-chars-forward " \t"))))
+ ((:function-name name)
+ (let ((case-fold-search t)
+ (name (regexp-quote name)))
+ (or
+ (re-search-forward
+ (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t)
+ (re-search-forward
+ (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t)
+ (re-search-forward
+ (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)))
+ (goto-char (match-beginning 0)))
+ ((:method name specializers &rest qualifiers)
+ (slime-search-method-location name specializers qualifiers))
+ ((: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))))
+ ;; Goes to "start" then looks for the anchor text, then moves
+ ;; delta from that position.
+ ((:text-anchored start text delta)
+ (goto-char start)
+ (slime-isearch text)
+ (forward-char delta)))))
+
+(defun slime-search-method-location (name specializers qualifiers)
+ ;; Look for a sequence of words (def<something> method name
+ ;; qualifers specializers don't look for "T" since it isn't requires
+ ;; (arg without t) as class is taken as such.
+ (let* ((case-fold-search t)
+ (name (regexp-quote name))
+ (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>"))
+ qualifiers ""))
+ (specializers (mapconcat (lambda (el)
+ (if (eql (aref el 0) ?\()
+ (let ((spec (read el)))
+ (if (eq (car spec) 'EQL)
+ (concat ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" (format "%s" (second spec)) ")")
+ (error "don't understand specializer: %s,%s" el (car spec))))
+ (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>")))
+ (remove "T" specializers) ""))
+ (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name
+ qualifiers specializers)))
+ (or (and (re-search-forward regexp nil t)
+ (goto-char (match-beginning 0)))
+ ;; (slime-goto-location-position `(:function-name ,name))
+ )))
+
+(defun slime-search-call-site (fname)
+ "Move to the place where FNAME called.
+Don't move if there are multiple or no calls in the current defun."
+ (save-restriction
+ (narrow-to-defun)
+ (let ((start (point))
+ (regexp (concat "(" fname "[\n \t]")))
+ (cond ((and (re-search-forward regexp nil t)
+ (not (re-search-forward regexp nil t)))
+ (goto-char (match-beginning 0)))
+ (t (goto-char start))))))
+
+(defun slime-goto-source-location (location &optional noerror)
+ "Move to the source location LOCATION. Several kinds of locations
+are supported:
+
+<location> ::= (:location <buffer> <position> <hints>)
+ | (:error <message>)
+
+<buffer> ::= (:file <filename>)
+ | (:buffer <buffername>)
+ | (:source-form <string>)
+ | (:zip <file> <entry>)
+
+<position> ::= (:position <fixnum> [<align>]) ; 1 based
+ | (:line <line> [<column>])
+ | (:function-name <string>)
+ | (:source-path <list> <start-position>)
+ | (:text-anchored <fixnum> <string> <fixnum>)
+ | (:method <name string> <specializer strings> . <qualifiers strings>)"
+ (destructure-case location
+ ((:location buffer position hints)
+ (slime-goto-location-buffer buffer)
+ (slime-goto-location-position position)
+ (when-let (snippet (getf hints :snippet))
+ (slime-isearch snippet))
+ (when-let (fname (getf hints :call-site))
+ (slime-search-call-site fname)))
+ ((:error message)
+ (if noerror
+ (slime-message "%s" message)
+ (error "%s" message)))))
+
+(defmacro slime-point-moves-p (&rest body)
+ "Execute BODY and return true if the current buffer's point moved."
+ (let ((pointvar (gensym "point-")))
+ `(let ((,pointvar (point)))
+ (save-current-buffer ,@body)
+ (/= ,pointvar (point)))))
+
+(put 'slime-point-moves-p 'lisp-indent-function 0)
+
+(defun slime-forward-sexp (&optional count)
+ "Like `forward-sexp', but understands reader-conditionals (#- and #+)."
+ (dotimes (i (or count 1))
+ (while (slime-point-moves-p (slime-forward-blanks)
+ (slime-forward-reader-comment)
+ (slime-forward-reader-conditional)))
+ (forward-sexp)))
+
+(defun slime-forward-blanks ()
+ "Move forward over all whitespace and newlines at point."
+ (ignore-errors
+ (while (slime-point-moves-p
+ (skip-syntax-forward " ")
+ ;; newlines aren't in lisp-mode's whitespace syntax class
+ (when (eolp) (forward-char))))))
+
+;; Emacs 21's forward-sexp understands #| |# comments in lisp-mode
+;; buffers, but (at least) Emacs 20's doesn't, so here it is.
+(defun slime-forward-reader-comment ()
+ "Move forward over #|...|# reader comments. The comments may be nested."
+ (when (looking-at "#|")
+ (goto-char (match-end 0))
+ (while (not (looking-at "|#"))
+ (re-search-forward (regexp-opt '("|#" "#|")))
+ (goto-char (match-beginning 0))
+ (when (looking-at "#|") ; nested comment
+ (slime-forward-reader-comment)))
+ (goto-char (match-end 0))))
+
+(defun slime-forward-reader-conditional ()
+ "Move past any reader conditional (#+ or #-) at point."
+ (when (or (looking-at "#\\+")
+ (looking-at "#-"))
+ (goto-char (match-end 0))
+ (let* ((plus-conditional-p (eq (char-before) ?+))
+ (result (slime-eval-feature-conditional (read (current-buffer)))))
+ (unless (if plus-conditional-p result (not result))
+ ;; skip this sexp
+ (slime-forward-sexp)))))
+
+(defun slime-keywordify (symbol)
+ "Make a keyword out of the symbol SYMBOL."
+ (let ((name (downcase (symbol-name symbol))))
+ (intern (if (eq ?: (aref name 0))
+ name
+ (concat ":" name)))))
+
+(defun slime-eval-feature-conditional (e)
+ "Interpret a reader conditional expression."
+ (if (symbolp e)
+ (memq (slime-keywordify e) (slime-lisp-features))
+ (funcall (ecase (slime-keywordify (car e))
+ (:and #'every)
+ (:or #'some)
+ (:not (lambda (f l) (not (apply f l)))))
+ #'slime-eval-feature-conditional
+ (cdr e))))
+
+
+;;;;; Incremental search
+;;
+;; Search for the longest match of a string in either direction.
+;;
+;; This is for locating text that is expected to be near the point and
+;; may have been modified (but hopefully not near the beginning!)
+
+(defun slime-isearch (string)
+ "Find the longest occurence of STRING either backwards of forwards.
+If multiple matches exist the choose the one nearest to point."
+ (goto-char
+ (let* ((start (point))
+ (len1 (slime-isearch-with-function 'search-forward string))
+ (pos1 (point)))
+ (goto-char start)
+ (let* ((len2 (slime-isearch-with-function 'search-backward string))
+ (pos2 (point)))
+ (cond ((and len1 len2)
+ ;; Have a match in both directions
+ (cond ((= len1 len2)
+ ;; Both are full matches -- choose the nearest.
+ (if (< (abs (- start pos1))
+ (abs (- start pos2)))
+ pos1 pos2))
+ ((> len1 len2) pos1)
+ ((> len2 len1) pos2)))
+ (len1 pos1)
+ (len2 pos2)
+ (t start))))))
+
+(defun slime-isearch-with-function (search-fn string)
+ "Search for the longest substring of STRING using SEARCH-FN.
+SEARCH-FN is either the symbol `search-forward' or `search-backward'."
+ (unless (string= string "")
+ (loop for i from 1 to (length string)
+ while (funcall search-fn (substring string 0 i) nil t)
+ for match-data = (match-data)
+ do (case search-fn
+ (search-forward (goto-char (match-beginning 0)))
+ (search-backward (goto-char (1+ (match-end 0)))))
+ finally (return (if (null match-data)
+ nil
+ ;; Finish based on the last successful match
+ (store-match-data match-data)
+ (goto-char (match-beginning 0))
+ (- (match-end 0) (match-beginning 0)))))))
+
+
+;;;;; Visiting and navigating the overlays of compiler notes
+
+(defvar slime-compilation-just-finished nil
+ "A buffer local variable which is T when we've just compiled a
+buffer and haven't yet started navigating its notes.")
+(make-variable-buffer-local 'slime-compilation-just-finished)
+
+(defun slime-next-note ()
+ "Go to and describe the next compiler note in the buffer."
+ (interactive)
+ (let ((here (point)))
+ (when (and slime-goto-first-note-after-compilation
+ slime-compilation-just-finished)
+ (goto-char (point-min))
+ (setf slime-compilation-just-finished nil))
+ (slime-find-next-note)
+ (if (slime-note-at-point)
+ (slime-show-note (slime-note-at-point))
+ (progn
+ (goto-char here)
+ (message "No next note.")))))
+
+(defun slime-previous-note ()
+ "Go to and describe the previous compiler note in the buffer."
+ (interactive)
+ (let ((here (point)))
+ (when (and slime-goto-first-note-after-compilation
+ slime-compilation-just-finished)
+ (goto-char (point-max))
+ (setf slime-compilation-just-finished nil))
+ (slime-find-previous-note)
+ (if (slime-note-at-point)
+ (slime-show-note (slime-note-at-point))
+ (progn
+ (goto-char here)
+ (message "No previous note.")))))
+
+(defun slime-remove-notes ()
+ "Remove compiler-note annotations from the current buffer."
+ (interactive)
+ (slime-remove-old-overlays))
+
+(defun slime-show-note (overlay)
+ "Present the details of a compiler note to the user."
+ (slime-temporarily-highlight-note overlay)
+ (let ((message (get-char-property (point) 'help-echo)))
+ (slime-message "%s" (if (zerop (length message)) "\"\"" message))))
+
+(defun slime-temporarily-highlight-note (overlay)
+ "Temporarily highlight a compiler note's overlay.
+The highlighting is designed to both make the relevant source more
+visible, and to highlight any further notes that are nested inside the
+current one.
+
+The highlighting is automatically undone before the next Emacs command."
+ (lexical-let ((old-face (overlay-get overlay 'face))
+ (overlay overlay))
+ (push (lambda () (overlay-put overlay 'face old-face))
+ slime-pre-command-actions)
+ (overlay-put overlay 'face 'slime-highlight-face)))
+
+
+;;;;; Overlay lookup operations
+
+(defun slime-note-at-point ()
+ "Return the overlay for a note starting at point, otherwise NIL."
+ (find (point) (slime-note-overlays-at-point)
+ :key 'overlay-start))
+
+(defun slime-note-overlay-p (overlay)
+ "Return true if OVERLAY represents a compiler note."
+ (overlay-get overlay 'slime))
+
+(defun slime-note-overlays-at-point ()
+ "Return a list of all note overlays that are under the point."
+ (remove-if-not 'slime-note-overlay-p (overlays-at (point))))
+
+(defun slime-find-next-note ()
+ "Go to the next position with the `slime-note' text property.
+Retuns true if such a position is found."
+ (slime-find-note 'next-single-char-property-change))
+
+(defun slime-find-previous-note ()
+ "Go to the next position with the `slime' text property.
+Returns true if such a position is found."
+ (slime-find-note 'previous-single-char-property-change))
+
+(defun slime-find-note (next-candidate-fn)
+ "Seek out the beginning of a note.
+NEXT-CANDIDATE-FN is called to find each new position for consideration."
+ (let ((origin (point)))
+ (loop do (goto-char (funcall next-candidate-fn (point) 'slime))
+ until (or (slime-note-at-point)
+ (eobp)
+ (bobp)))
+ (unless (slime-note-at-point)
+ (goto-char origin))))
+
+
+;;;; Arglist Display
+
+(defun slime-space (n)
+ "Insert a space and print some relevant information (function arglist).
+Designed to be bound to the SPC key. Prefix argument can be used to insert
+more than one space."
+ (interactive "p")
+ (self-insert-command n)
+ (when (and slime-space-information-p
+ (slime-background-activities-enabled-p))
+ (slime-echo-arglist)))
+
+(defvar slime-echo-arglist-function 'slime-show-arglist)
+
+(defun slime-echo-arglist ()
+ "Display the arglist of the current form in the echo area."
+ (funcall slime-echo-arglist-function))
+
+(defun slime-show-arglist ()
+ (let ((op (slime-operator-before-point)))
+ (when op
+ (slime-eval-async `(swank:operator-arglist ,op ,(slime-current-package))
+ (lambda (arglist)
+ (when arglist
+ (slime-message "%s" arglist)))))))
+
+(defun slime-operator-before-point ()
+ (ignore-errors
+ (save-excursion
+ (backward-up-list 1)
+ (down-list 1)
+ (slime-symbol-name-at-point))))
+
+
+;;;; Completion
+
+;; XXX those long names are ugly to read; long names an indicator for
+;; bad factoring?
+
+(defvar slime-completions-buffer-name "*Completions*")
+
+(make-variable-buffer-local
+ (defvar slime-complete-saved-window-configuration nil
+ "Window configuration before we show the *Completions* buffer.
+This is buffer local in the buffer where the completion is
+performed."))
+
+(make-variable-buffer-local
+ (defvar slime-completions-window nil
+ "The window displaying *Completions* after saving window configuration.
+If this window is no longer active or displaying the completions
+buffer then we can ignore `slime-complete-saved-window-configuration'."))
+
+(defun slime-complete-maybe-save-window-configuration ()
+ "Maybe save the current window configuration.
+Return true if the configuration was saved."
+ (unless (or slime-complete-saved-window-configuration
+ (get-buffer-window slime-completions-buffer-name))
+ (setq slime-complete-saved-window-configuration
+ (current-window-configuration))
+ t))
+
+(defun slime-complete-delay-restoration ()
+ (make-local-hook 'pre-command-hook)
+ (add-hook 'pre-command-hook
+ 'slime-complete-maybe-restore-window-configuration))
+
+(defun slime-complete-forget-window-configuration ()
+ (setq slime-complete-saved-window-configuration nil)
+ (setq slime-completions-window nil))
+
+(defun slime-complete-restore-window-configuration ()
+ "Restore the window config if available."
+ (remove-hook 'pre-command-hook
+ 'slime-complete-maybe-restore-window-configuration)
+ (when (and slime-complete-saved-window-configuration
+ (slime-completion-window-active-p))
+ ;; XEmacs does not allow us to restore a window configuration from
+ ;; pre-command-hook, so we do it asynchronously.
+ (slime-run-when-idle
+ (lambda ()
+ (save-excursion
+ (set-window-configuration
+ slime-complete-saved-window-configuration))
+ (setq slime-complete-saved-window-configuration nil)
+ (when (buffer-live-p slime-completions-buffer-name)
+ (kill-buffer slime-completions-buffer-name))))))
+
+(defun slime-complete-maybe-restore-window-configuration ()
+ "Restore the window configuration, if the following command
+terminates a current completion."
+ (remove-hook 'pre-command-hook
+ 'slime-complete-maybe-restore-window-configuration)
+ (condition-case err
+ (cond ((find last-command-char "()\"'`,# \r\n:")
+ (slime-complete-restore-window-configuration))
+ ((not (slime-completion-window-active-p))
+ (slime-complete-forget-window-configuration))
+ (t
+ (slime-complete-delay-restoration)))
+ (error
+ ;; Because this is called on the pre-command-hook, we mustn't let
+ ;; errors propagate.
+ (message "Error in slime-complete-restore-window-configuration: %S" err))))
+
+(defun slime-completion-window-active-p ()
+ "Is the completion window currently active?"
+ (and (window-live-p slime-completions-window)
+ (equal (buffer-name (window-buffer slime-completions-window))
+ slime-completions-buffer-name)))
+
+(defun slime-display-completion-list (completions base)
+ (let ((savedp (slime-complete-maybe-save-window-configuration)))
+ (with-output-to-temp-buffer slime-completions-buffer-name
+ (display-completion-list completions)
+ (let ((offset (- (point) 1 (length base))))
+ (with-current-buffer standard-output
+ (setq completion-base-size offset)
+ (set-syntax-table lisp-mode-syntax-table))))
+ (when savedp
+ (setq slime-completions-window
+ (get-buffer-window slime-completions-buffer-name)))))
+
+(defun slime-display-or-scroll-completions (completions base)
+ (cond ((and (eq last-command this-command)
+ (slime-completion-window-active-p))
+ (slime-scroll-completions))
+ (t
+ (slime-display-completion-list completions base)))
+ (slime-complete-delay-restoration))
+
+(defun slime-scroll-completions ()
+ (let ((window slime-completions-window))
+ (with-current-buffer (window-buffer window)
+ (if (pos-visible-in-window-p (point-max) window)
+ (set-window-start window (point-min))
+ (save-selected-window
+ (select-window window)
+ (scroll-up))))))
+
+(defun slime-complete-symbol ()
+ "Complete the symbol at point.
+
+Completion is performed by `slime-complete-symbol-function'."
+ (interactive)
+ (funcall slime-complete-symbol-function))
+
+(defun slime-simple-complete-symbol ()
+ "Complete the symbol at point.
+Perform completion more similar to Emacs' complete-symbol."
+ (or (slime-maybe-complete-as-filename)
+ (let* ((end (point))
+ (beg (slime-symbol-start-pos))
+ (prefix (buffer-substring-no-properties beg end))
+ (result (slime-simple-completions prefix)))
+ (destructuring-bind (completions partial) result
+ (if (null completions)
+ (progn (slime-minibuffer-respecting-message
+ "Can't find completion for \"%s\"" prefix)
+ (ding)
+ (slime-complete-restore-window-configuration))
+ (insert-and-inherit (substring partial (length prefix)))
+ (cond ((slime-length= completions 1)
+ (slime-minibuffer-respecting-message "Sole completion")
+ (slime-complete-restore-window-configuration))
+ ;; Incomplete
+ (t
+ (slime-minibuffer-respecting-message
+ "Complete but not unique")
+ (slime-display-or-scroll-completions completions
+ partial))))))))
+
+(defun slime-maybe-complete-as-filename ()
+ "If point is at a string starting with \", complete it as filename.
+Return nil iff if point is not at filename."
+ (if (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
+ (let ((comint-completion-addsuffix '("/" . "\"")))
+ (if slime-when-complete-filename-expand
+ (comint-replace-by-expanded-filename)
+ (comint-dynamic-complete-as-filename))
+ t)
+ nil))
+
+(defun slime-minibuffer-respecting-message (format &rest format-args)
+ "Display TEXT as a message, without hiding any minibuffer contents."
+ (let ((text (format " [%s]" (apply #'format format format-args))))
+ (if (minibuffer-window-active-p (minibuffer-window))
+ (if (fboundp 'temp-minibuffer-message) ;; XEmacs
+ (temp-minibuffer-message text)
+ (minibuffer-message text))
+ (message "%s" text))))
+
+(defvar slime-read-expression-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\t" 'slime-complete-symbol)
+ (define-key map "\M-\t" 'slime-complete-symbol)
+ map)
+ "Minibuffer keymap used for reading CL expressions.")
+
+(defvar slime-read-expression-history '()
+ "History list of expressions read from the minibuffer.")
+
+(defun slime-read-from-minibuffer (prompt &optional initial-value)
+ "Read a string from the minibuffer, prompting with PROMPT.
+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-current-package))
+ (connection (slime-connection)))
+ (lambda ()
+ (setq slime-buffer-package package)
+ (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
+ nil 'slime-read-expression-history)))
+
+(defun slime-bogus-completion-alist (list)
+ "Make an alist out of list.
+The same elements go in the CAR, and nil in the CDR. To support the
+apparently very stupid `try-completions' interface, that wants an
+alist but ignores CDRs."
+ (mapcar (lambda (x) (cons x nil)) list))
+
+(defun slime-simple-completions (prefix)
+ (slime-eval `(swank:simple-completions ,prefix ',(slime-current-package))))
+
+
+;;;; Edit definition
+
+(defvar slime-find-definition-history-ring (make-ring 20)
+ "History ring recording the definition-finding \"stack\".")
+
+(defun slime-push-definition-stack (&optional marker narrowing-configuration)
+ "Add MARKER and NARROWING-CONFIGURATION to the edit-definition history stack.
+If MARKER is nil, use the current point. If NARROWING-CONFIGURATION is nil,
+look if the current buffer is narrowed, and if so use the relevant values."
+ (ring-insert-at-beginning slime-find-definition-history-ring
+ (list (or marker (point-marker))
+ (or narrowing-configuration
+ (slime-current-narrowing-configuration)))))
+
+(defun slime-pop-find-definition-stack ()
+ "Pop the edit-definition stack and goto the location."
+ (interactive)
+ (unless (ring-empty-p slime-find-definition-history-ring)
+ (destructuring-bind (marker narrowing-cfg)
+ (ring-remove slime-find-definition-history-ring)
+ (let ((buffer (marker-buffer marker))
+ (narrowedp (slime-narrowing-configuration.narrowedp narrowing-cfg))
+ (narrow-beg (slime-narrowing-configuration.beg narrowing-cfg))
+ (narrow-end (slime-narrowing-configuration.end narrowing-cfg)))
+ (if (buffer-live-p buffer)
+ (progn (switch-to-buffer buffer)
+ (goto-char (marker-position marker))
+ (when narrowedp
+ (narrow-to-region narrow-beg narrow-end)))
+ ;; If this buffer was deleted, recurse to try the next one
+ (slime-pop-find-definition-stack))))))
+
+(defstruct (slime-definition (:conc-name slime-definition.)
+ (:type list))
+ dspec location)
+
+(defun slime-edit-definition (name &optional where)
+ "Lookup the definition of the name at point.
+If there's no name at point, or a prefix argument is given, then the
+function name is prompted."
+ (interactive (list (slime-read-symbol-name "Name: ")))
+ (let ((definitions (slime-eval `(swank:find-definitions-for-emacs ,name))))
+ (cond
+ ((null definitions)
+ (if slime-edit-definition-fallback-function
+ (funcall slime-edit-definition-fallback-function name)
+ (error "No known definition for: %s" name)))
+ ((and (slime-length= definitions 1)
+ (eql (car (slime-definition.location (car definitions))) :error))
+ (if slime-edit-definition-fallback-function
+ (funcall slime-edit-definition-fallback-function name)
+ (error "%s" (cadr (slime-definition.location (car definitions))))))
+ (t
+ (slime-goto-definition name definitions where)))))
+
+(defun slime-find-tag-if-tags-table-visited (name)
+ "Find tag (in current tags table) whose name contains NAME.
+If no tags table is visited, don't offer to visit one;
+just signal that no definition is known."
+ (if tags-table-list
+ (find-tag name)
+ (error "No known definition for: %s; use M-x visit-tags-table RET" name)))
+
+(defun slime-goto-definition (name definitions &optional where)
+ (slime-push-definition-stack)
+ (let ((all-locations-equal
+ (or (null definitions)
+ (let ((first-location (slime-definition.location (first definitions))))
+ (every (lambda (definition)
+ (equal (slime-definition.location definition)
+ first-location))
+ (rest definitions))))))
+ (if (and (slime-length> definitions 1)
+ (not all-locations-equal))
+ (slime-show-definitions name definitions)
+ (let ((def (car definitions)))
+ (destructure-case (slime-definition.location def)
+ ;; Take care of errors before switching any windows/buffers.
+ ((:error message)
+ (error "%s" message))
+ (t
+ (cond ((equal where 'window)
+ (slime-goto-definition-other-window (car definitions)))
+ ((equal where 'frame)
+ (let ((pop-up-frames t))
+ (slime-goto-definition-other-window (car definitions))))
+ (t
+ (slime-goto-source-location (slime-definition.location
+ (car definitions)))
+ (switch-to-buffer (current-buffer))))))))))
+
+(defun slime-goto-definition-other-window (definition)
+ (slime-pop-to-other-window)
+ (slime-goto-source-location (slime-definition.location definition))
+ (switch-to-buffer (current-buffer)))
+
+(defun slime-pop-to-other-window ()
+ "Pop to the other window, but not to any particular buffer."
+ (pop-to-buffer (current-buffer) t))
+
+(defun slime-edit-definition-other-window (name)
+ "Like `slime-edit-definition' but switch to the other window."
+ (interactive (list (slime-read-symbol-name "Symbol: ")))
+ (slime-edit-definition name 'window))
+
+(defun slime-edit-definition-other-frame (name)
+ "Like `slime-edit-definition' but switch to the other window."
+ (interactive (list (slime-read-symbol-name "Symbol: ")))
+ (slime-edit-definition name 'frame))
+
+(defun slime-edit-definition-with-etags (name)
+ (interactive (list (slime-read-symbol-name "Symbol: ")))
+ (let ((tagdefs (slime-etags-definitions name)))
+ (cond (tagdefs
+ (message "Using tag file...")
+ (slime-goto-definition name tagdefs))
+ (t
+ (error "No known definition for: %s" name)))))
+
+(defun slime-etags-definitions (name)
+ "Search definitions matching NAME in the tags file.
+The result is a (possibly empty) list of definitions."
+ (require 'etags)
+ (let ((defs '()))
+ (save-excursion
+ (let ((first-time t))
+ (while (visit-tags-table-buffer (not first-time))
+ (setq first-time nil)
+ (goto-char (point-min))
+ (while (search-forward name nil t)
+ (beginning-of-line)
+ (destructuring-bind (hint line &rest pos) (etags-snarf-tag)
+ (unless (eq hint t) ; hint==t if we are in a filename line
+ (let ((file (expand-file-name (file-of-tag))))
+ (let ((loc `(:location (:file ,file)
+ (:line ,line)
+ (:snippet ,hint))))
+ (push (list hint loc) defs))))))))
+ (reverse defs))))
+
+(defun slime-show-definitions (name definitions)
+ (slime-show-xrefs
+ `((,name . ,(loop for (dspec location) in definitions
+ collect (cons dspec location))))
+ 'definition
+ name
+ (slime-current-package)))
+
+;;;;; first-change-hook
+
+(defun slime-first-change-hook ()
+ "Notify Lisp that a source file's buffer has been modified."
+ ;; Be careful not to disturb anything!
+ ;; In particular if we muck up the match-data then query-replace
+ ;; breaks. -luke (26/Jul/2004)
+ (save-excursion
+ (save-match-data
+ (when (and (buffer-file-name)
+ (file-exists-p (buffer-file-name))
+ (slime-background-activities-enabled-p))
+ (let ((filename (slime-to-lisp-filename (buffer-file-name))))
+ (slime-eval-async `(swank:buffer-first-change ,filename)))))))
+
+(defun slime-setup-first-change-hook ()
+ (add-hook (make-local-variable 'first-change-hook)
+ 'slime-first-change-hook))
+
+(add-hook 'slime-mode-hook 'slime-setup-first-change-hook)
+
+
+;;;; Eval for Lisp
+
+(defun slime-eval-for-lisp (thread tag form-string)
+ (let ((ok nil)
+ (value nil)
+ (c (slime-connection)))
+ (unwind-protect (progn
+ (slime-check-eval-in-emacs-enabled)
+ (setq value (eval (read form-string)))
+ (setq ok t))
+ (let ((result (if ok `(:ok ,value) `(:abort))))
+ (slime-dispatch-event `(:emacs-return ,thread ,tag ,result) c)))))
+
+(defun slime-check-eval-in-emacs-enabled ()
+ "Raise an error if `slime-enable-evaluate-in-emacs' isn't true."
+ (unless slime-enable-evaluate-in-emacs
+ (error "slime-eval-in-emacs disabled for security. Set slime-enable-evaluate-in-emacs true to enable it.")))
+
+
+;;;; `ED'
+
+(defvar slime-ed-frame nil
+ "The frame used by `slime-ed'.")
+
+(defcustom slime-ed-use-dedicated-frame t
+ "*When non-nil, `slime-ed' will create and reuse a dedicated frame."
+ :type 'boolean
+ :group 'slime-mode)
+
+(defun slime-ed (what)
+ "Edit WHAT.
+
+WHAT can be:
+ A filename (string),
+ A list (FILENAME LINE [COLUMN]),
+ A list (FILENAME :charpos CHARPOS),
+ A function name (symbol or cons),
+ nil.
+
+This is for use in the implementation of COMMON-LISP:ED."
+ ;; Without `save-excursion' very strange things happen if you call
+ ;; (swank:ed-in-emacs X) from the REPL. -luke (18/Jan/2004)
+ (save-excursion
+ (when slime-ed-use-dedicated-frame
+ (unless (and slime-ed-frame (frame-live-p slime-ed-frame))
+ (setq slime-ed-frame (make-frame)))
+ (select-frame slime-ed-frame))
+ (cond ((stringp what)
+ (find-file (slime-from-lisp-filename what)))
+ ((and (consp what) (stringp (first what)))
+ (find-file (first (slime-from-lisp-filename what)))
+ (cond
+ ((eql (second what) :charpos)
+ (goto-char (third what)))
+ (t
+ (goto-line (second what))
+ ;; Find the correct column, without going past the end of
+ ;; the line.
+ (let ((col (third what)))
+ (while (and col
+ (< (point) (point-at-eol))
+ (/= (decf col) -1))
+ (forward-char 1))))))
+ ((and what (symbolp what))
+ (slime-edit-definition (symbol-name what)))
+ ((consp what)
+ (slime-edit-definition (prin1-to-string what)))
+ (t nil)))) ; nothing in particular
+
+
+;;;; Interactive evaluation.
+
+(defun slime-interactive-eval (string)
+ "Read and evaluate STRING and print value in minibuffer.
+
+Note: If a prefix argument is in effect then the result will be
+inserted in the current buffer."
+ (interactive (list (slime-read-from-minibuffer "Slime Eval: ")))
+ (slime-insert-transcript-delimiter string)
+ (cond ((not current-prefix-arg)
+ (slime-eval-with-transcript `(swank:interactive-eval ,string)
+ 'slime-display-eval-result))
+ (t
+ (slime-eval-print string))))
+
+(defun slime-display-eval-result (value)
+ (slime-message "%s" value))
+
+(defun slime-eval-print (string)
+ "Eval STRING in Lisp; insert any output and the result at point."
+ (slime-eval-async `(swank:eval-and-grab-output ,string)
+ (lexical-let ((buffer (current-buffer)))
+ (lambda (result)
+ (with-current-buffer buffer
+ (destructuring-bind (output value) result
+ (insert output value)))))))
+
+(defun slime-eval-with-transcript (form &optional fn)
+ "Send FROM and PACKAGE to Lisp and pass the result to FN.
+Display the result in the message area, if FN is nil.
+Show the output buffer if the evaluation causes any output."
+ (with-current-buffer (slime-output-buffer)
+ (slime-with-output-end-mark
+ (slime-mark-output-start)))
+ (with-lexical-bindings (fn)
+ (slime-eval-async form
+ (lambda (value)
+ (with-current-buffer (slime-output-buffer)
+ (slime-show-last-output)
+ (cond (fn (funcall fn value))
+ (t (message "%s" value))))))))
+
+(defun slime-eval-describe (form)
+ "Evaluate FORM in Lisp and display the result in a new buffer."
+ (lexical-let ((package (slime-current-package)))
+ (slime-eval-with-transcript
+ form (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-before-markers "\n"))
+ (slime-propertize-region '(slime-transcript-delimiter t)
+ (insert-before-markers
+ ";;;; " (subst-char-in-string ?\n ?\
+ (substring string 0
+ (min 60 (length string))))
+ " ...\n")))))
+
+(defun slime-display-buffer-region (buffer start end &optional other-window)
+ "Like `display-buffer', but only display the specified region."
+ (let ((window-min-height 1))
+ (with-current-buffer buffer
+ (save-excursion
+ (save-restriction
+ (goto-char start)
+ (beginning-of-line)
+ (narrow-to-region (point) end)
+ (let ((window (display-buffer buffer other-window t)))
+ (set-window-start window (point))
+ (unless (or (one-window-p t)
+ (/= (frame-width) (window-width)))
+ (set-window-text-height window (/ (1- (frame-height)) 2)))
+ (shrink-window-if-larger-than-buffer window)
+ window))))))
+
+(defun slime-last-expression ()
+ (buffer-substring-no-properties
+ (save-excursion (backward-sexp) (point))
+ (point)))
+
+(defun slime-eval-last-expression ()
+ "Evaluate the expression preceding point."
+ (interactive)
+ (slime-interactive-eval (slime-last-expression)))
+
+(defun slime-eval-last-expression-display-output ()
+ "Display output buffer and evaluate the expression preceding point."
+ (interactive)
+ (slime-display-output-buffer)
+ (slime-interactive-eval (slime-last-expression)))
+
+(defun slime-eval-defun ()
+ "Evaluate the current toplevel form.
+Use `slime-re-evaluate-defvar' if the from starts with '(defvar'"
+ (interactive)
+ (let ((form (slime-defun-at-point)))
+ (cond ((string-match "^(defvar " form)
+ (slime-re-evaluate-defvar form))
+ (t
+ (slime-interactive-eval form)))))
+
+(defun slime-eval-region (start end)
+ "Evaluate region."
+ (interactive "r")
+ (slime-eval-with-transcript
+ `(swank:interactive-eval-region
+ ,(buffer-substring-no-properties start end))))
+
+(defun slime-eval-buffer ()
+ "Evaluate the current buffer.
+The value is printed in the echo area."
+ (interactive)
+ (slime-eval-region (point-min) (point-max)))
+
+(defun slime-re-evaluate-defvar (form)
+ "Force the re-evaluaton of the defvar form before point.
+
+First make the variable unbound, then evaluate the entire form."
+ (interactive (list (slime-last-expression)))
+ (slime-eval-with-transcript `(swank:re-evaluate-defvar ,form)))
+
+(defun slime-pprint-eval-last-expression ()
+ "Evaluate the form before point; pprint the value in a buffer."
+ (interactive)
+ (slime-eval-describe `(swank:pprint-eval ,(slime-last-expression))))
+
+(defun slime-eval-print-last-expression (string)
+ "Evaluate sexp before point; print value into the current buffer"
+ (interactive (list (slime-last-expression)))
+ (insert "\n")
+ (slime-eval-print string))
+
+(defun slime-call-defun ()
+ "Insert a call to the function defined around point into the REPL."
+ (interactive)
+ (let ((toplevel (slime-parse-toplevel-form)))
+ (unless (and (consp toplevel)
+ (member (car toplevel) '(:defun :defmethod :defgeneric))
+ (symbolp (cadr toplevel)))
+ (error "Not in a function definition"))
+ (let* ((symbol (cadr toplevel))
+ (function-call
+ (format "(%s " (slime-qualify-cl-symbol-name symbol))))
+ (slime-switch-to-output-buffer)
+ (goto-char slime-repl-input-start-mark)
+ (insert function-call)
+ (save-excursion (insert ")")))))
+
+;;;; Edit Lisp value
+;;;
+(defun slime-edit-value (form-string)
+ "\\<slime-edit-value-mode-map>\
+Edit the value of a setf'able form in a new buffer.
+The value is inserted into a temporary buffer for editing and then set
+in Lisp when committed with \\[slime-edit-value-commit]."
+ (interactive
+ (list (slime-read-from-minibuffer "Edit value (evaluated): "
+ (slime-sexp-at-point))))
+ (slime-eval-async `(swank:value-for-editing ,form-string)
+ (lexical-let ((form-string form-string)
+ (package (slime-current-package)))
+ (lambda (result)
+ (slime-edit-value-callback form-string result
+ package)))))
+
+(make-variable-buffer-local
+ (defvar slime-edit-form-string nil
+ "The form being edited by `slime-edit-value'."))
+
+(define-minor-mode slime-edit-value-mode
+ "Mode for editing a Lisp value."
+ nil
+ " edit"
+ '(("\C-c\C-c" . slime-edit-value-commit)))
+
+(defun slime-edit-value-callback (form-string current-value package)
+ (let ((name (generate-new-buffer-name (format "*Edit %s*" form-string))))
+ (with-current-buffer (slime-get-temp-buffer-create name :mode 'lisp-mode)
+ (slime-mode 1)
+ (slime-temp-buffer-mode -1) ; don't want binding of 'q'
+ (slime-edit-value-mode 1)
+ (setq slime-edit-form-string form-string)
+ (setq slime-buffer-connection (slime-connection))
+ (setq slime-buffer-package package)
+ (insert current-value))))
+
+(defun slime-edit-value-commit ()
+ "Commit the edited value to the Lisp image.
+\\(See `slime-edit-value'.)"
+ (interactive)
+ (if (null slime-edit-form-string)
+ (error "Not editing a value.")
+ (let ((value (buffer-substring-no-properties (point-min) (point-max))))
+ (lexical-let ((buffer (current-buffer)))
+ (slime-eval-async `(swank:commit-edited-value ,slime-edit-form-string
+ ,value)
+ (lambda (_)
+ (with-current-buffer buffer
+ (slime-temp-buffer-quit t))))))))
+
+;;;; Tracing
+
+(defun slime-redirect-trace-output ()
+ "Redirect the trace output to a separate Emacs buffer."
+ (interactive)
+ (let ((buffer (get-buffer-create "*SLIME Trace Output*")))
+ (with-current-buffer buffer
+ (let ((marker (copy-marker (buffer-size)))
+ (target (incf slime-last-output-target-id)))
+ (puthash target marker slime-output-target-to-marker)
+ (slime-eval `(swank:redirect-trace-output ,target))))
+ ;; Note: We would like the entries in
+ ;; slime-output-target-to-marker to disappear when the buffers are
+ ;; killed. We cannot just make the hash-table ":weakness 'value"
+ ;; -- there is no reference from the buffers to the markers in the
+ ;; buffer, so entries would disappear even though the buffers are
+ ;; alive. Best solution might be to make buffer-local variables
+ ;; that keep the markers. --mkoeppe
+ (pop-to-buffer buffer)))
+
+(defun slime-untrace-all ()
+ "Untrace all functions."
+ (interactive)
+ (slime-eval `(swank:untrace-all)))
+
+(defun slime-toggle-trace-fdefinition (&optional using-context-p)
+ "Toggle trace."
+ (interactive "P")
+ (let* ((spec (if using-context-p
+ (slime-extract-context)
+ (slime-symbol-name-at-point)))
+ (spec (slime-trace-query spec)))
+ (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))))
+
+(defun slime-trace-query (spec)
+ "Ask the user which function to trace; SPEC is the default.
+The result is a string."
+ (cond ((null spec)
+ (slime-read-from-minibuffer "(Un)trace: "))
+ ((stringp spec)
+ (slime-read-from-minibuffer "(Un)trace: " spec))
+ (t
+ (destructure-case spec
+ ((setf n)
+ (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+ (((:defun :defmacro) n)
+ (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n)))
+ ((:defgeneric n)
+ (let* ((name (prin1-to-string n))
+ (answer (slime-read-from-minibuffer "(Un)trace: " name)))
+ (cond ((and (string= name answer)
+ (y-or-n-p (concat "(Un)trace also all "
+ "methods implementing "
+ name "? ")))
+ (prin1-to-string `(:defgeneric ,n)))
+ (t
+ answer))))
+ ((:defmethod &rest _)
+ (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec)))
+ ((:call caller callee)
+ (let* ((callerstr (prin1-to-string caller))
+ (calleestr (prin1-to-string callee))
+ (answer (slime-read-from-minibuffer "(Un)trace: "
+ calleestr)))
+ (cond ((and (string= calleestr answer)
+ (y-or-n-p (concat "(Un)trace only when " calleestr
+ " is called by " callerstr "? ")))
+ (prin1-to-string `(:call ,caller ,callee)))
+ (t
+ answer))))
+ (((:labels :flet) &rest _)
+ (slime-read-from-minibuffer "(Un)trace local function: "
+ (prin1-to-string spec)))))))
+
+(defun slime-extract-context ()
+ "Parse the context for the symbol at point.
+Nil is returned if there's no symbol at point. Otherwise we detect
+the following cases (the . shows the point position):
+
+ (defun n.ame (...) ...) -> (:defun name)
+ (defun (setf n.ame) (...) ...) -> (:defun (setf name))
+ (defmethod n.ame (...) ...) -> (:defmethod name (...))
+ (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name)
+ (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name)
+ (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name)
+ (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name))
+
+For other contexts we return the symbol at point."
+ (let ((name (slime-symbol-name-at-point)))
+ (if name
+ (let ((symbol (read name)))
+ (or (progn ;;ignore-errors
+ (slime-parse-context symbol))
+ symbol)))))
+
+(defun slime-parse-context (name)
+ (save-excursion
+ (cond ((slime-in-expression-p '(defun *)) `(:defun ,name))
+ ((slime-in-expression-p '(defmacro *)) `(:defmacro ,name))
+ ((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name))
+ ((slime-in-expression-p '(setf *))
+ ;;a setf-definition, but which?
+ (backward-up-list 1)
+ (slime-parse-context `(setf ,name)))
+ ((slime-in-expression-p '(defmethod *))
+ (unless (looking-at "\\s ")
+ (forward-sexp 1)) ; skip over the methodname
+ (let (qualifiers arglist)
+ (loop for e = (read (current-buffer))
+ until (listp e) do (push e qualifiers)
+ finally (setq arglist e))
+ `(:defmethod ,name ,@qualifiers
+ ,(slime-arglist-specializers arglist))))
+ ((and (symbolp name)
+ (slime-in-expression-p `(,name)))
+ ;; looks like a regular call
+ (let ((toplevel (ignore-errors (slime-parse-toplevel-form))))
+ (cond ((slime-in-expression-p `(setf (*))) ;a setf-call
+ (if toplevel
+ `(:call ,toplevel (setf ,name))
+ `(setf ,name)))
+ ((not toplevel)
+ name)
+ ((slime-in-expression-p `(labels ((*))))
+ `(:labels ,toplevel ,name))
+ ((slime-in-expression-p `(flet ((*))))
+ `(:flet ,toplevel ,name))
+ (t
+ `(:call ,toplevel ,name)))))
+ (t
+ name))))
+
+(defun slime-in-expression-p (pattern)
+ "A helper function to determine the current context.
+The pattern can have the form:
+ pattern ::= () ;matches always
+ | (*) ;matches inside a list
+ | (<symbol> <pattern>) ;matches if the first element in
+ ; the current list is <symbol> and
+ ; if <pattern> matches.
+ | ((<pattern>)) ;matches if we are in a nested list."
+ (save-excursion
+ (let ((path (reverse (slime-pattern-path pattern))))
+ (loop for p in path
+ always (ignore-errors
+ (etypecase p
+ (symbol (slime-beginning-of-list)
+ (eq (read (current-buffer)) p))
+ (number (backward-up-list p)
+ t)))))))
+
+(defun slime-pattern-path (pattern)
+ ;; Compute the path to the * in the pattern to make matching
+ ;; easier. The path is a list of symbols and numbers. A number
+ ;; means "(down-list <n>)" and a symbol "(look-at <sym>)")
+ (if (null pattern)
+ '()
+ (etypecase (car pattern)
+ ((member *) '())
+ (symbol (cons (car pattern) (slime-pattern-path (cdr pattern))))
+ (cons (cons 1 (slime-pattern-path (car pattern)))))))
+
+(defun slime-beginning-of-list (&optional up)
+ "Move backward the the beginning of the current expression.
+Point is placed before the first expression in the list."
+ (backward-up-list (or up 1))
+ (down-list 1)
+ (skip-syntax-forward " "))
+
+(defun slime-parse-toplevel-form ()
+ (save-excursion
+ (beginning-of-defun)
+ (down-list 1)
+ (forward-sexp 1)
+ (slime-parse-context (read (current-buffer)))))
+
+(defun slime-arglist-specializers (arglist)
+ (cond ((or (null arglist)
+ (member (first arglist) '(&optional &key &rest &aux)))
+ (list))
+ ((consp (first arglist))
+ (cons (second (first arglist))
+ (slime-arglist-specializers (rest arglist))))
+ (t
+ (cons 't
+ (slime-arglist-specializers (rest arglist))))))
+
+(defun slime-disassemble-symbol (symbol-name)
+ "Display the disassembly for SYMBOL-NAME."
+ (interactive (list (slime-read-symbol-name "Disassemble: ")))
+ (slime-eval-describe `(swank:disassemble-symbol ,symbol-name)))
+
+(defun slime-undefine-function (symbol-name)
+ "Unbind the function slot of SYMBOL-NAME."
+ (interactive (list (slime-read-symbol-name "fmakunbound: " t)))
+ (slime-eval-async `(swank:undefine-function ,symbol-name)
+ (lambda (result) (message "%s" result))))
+
+(defun slime-load-file (filename)
+ "Load the Lisp file FILENAME."
+ (interactive (list
+ (read-file-name "Load file: " nil nil
+ nil (if (buffer-file-name)
+ (file-name-nondirectory
+ (buffer-file-name))))))
+ (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename))))
+ (slime-eval-with-transcript `(swank:load-file ,lisp-filename))))
+
+
+
+
+;;;; Profiling
+
+(defun slime-toggle-profile-fdefinition (fname-string)
+ "Toggle profiling for FNAME-STRING."
+ (interactive (list (slime-read-from-minibuffer
+ "(Un)Profile: "
+ (slime-symbol-name-at-point))))
+ (slime-eval-async `(swank:toggle-profile-fdefinition ,fname-string)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-unprofile-all ()
+ "Unprofile all functions."
+ (interactive)
+ (slime-eval-async '(swank:unprofile-all)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profile-report ()
+ "Print profile report."
+ (interactive)
+ (slime-eval-with-transcript '(swank:profile-report)))
+
+(defun slime-profile-reset ()
+ "Reset profile counters."
+ (interactive)
+ (slime-eval-async (slime-eval `(swank:profile-reset))
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profiled-functions ()
+ "Return list of names of currently profiled functions."
+ (interactive)
+ (slime-eval-async `(swank:profiled-functions)
+ (lambda (r) (message "%s" r))))
+
+(defun slime-profile-package (package callers methods)
+ "Profile all functions in PACKAGE.
+If CALLER is non-nil names have counts of the most common calling
+functions recorded.
+If METHODS is non-nil, profile all methods of all generic function
+having names in the given package."
+ (interactive (list (slime-read-package-name "Package: ")
+ (y-or-n-p "Record the most common callers? ")
+ (y-or-n-p "Profile methods? ")))
+ (slime-eval-async `(swank:profile-package ,package ,callers ,methods)
+ (lambda (r) (message "%s" r))))
+
+
+
+;;;; Documentation
+
+(defun slime-hyperspec-lookup (symbol-name)
+ "A wrapper for `hyperspec-lookup'"
+ (interactive (list (let* ((symbol-at-point (slime-symbol-name-at-point))
+ (stripped-symbol
+ (and symbol-at-point
+ (downcase
+ (common-lisp-hyperspec-strip-cl-package
+ symbol-at-point)))))
+ (if (and stripped-symbol
+ (intern-soft stripped-symbol
+ common-lisp-hyperspec-symbols))
+ stripped-symbol
+ (completing-read
+ "Look up symbol in Common Lisp HyperSpec: "
+ common-lisp-hyperspec-symbols #'boundp
+ t stripped-symbol
+ 'common-lisp-hyperspec-history)))))
+ (hyperspec-lookup symbol-name))
+
+(defun slime-show-description (string package)
+ (slime-with-output-to-temp-buffer ("*SLIME Description*")
+ package (princ string)))
+
+(defun slime-describe-symbol (symbol-name)
+ "Describe the symbol at point."
+ (interactive (list (slime-read-symbol-name "Describe symbol: ")))
+ (when (not symbol-name)
+ (error "No symbol given"))
+ (slime-eval-describe `(swank:describe-symbol ,symbol-name)))
+
+(defun slime-documentation (symbol-name)
+ "Display function- or symbol-documentation for SYMBOL-NAME."
+ (interactive (list (slime-read-symbol-name "Documentation for symbol: ")))
+ (when (not symbol-name)
+ (error "No symbol given"))
+ (slime-eval-describe
+ `(swank:documentation-symbol ,symbol-name "(not documented)")))
+
+(defun slime-describe-function (symbol-name)
+ (interactive (list (slime-read-symbol-name "Describe symbol: ")))
+ (when (not symbol-name)
+ (error "No symbol given"))
+ (slime-eval-describe `(swank:describe-function ,symbol-name)))
+
+(defun slime-apropos-summary (string case-sensitive-p package only-external-p)
+ "Return a short description for the performed apropos search."
+ (concat (if case-sensitive-p "Case-sensitive " "")
+ "Apropos for "
+ (format "%S" string)
+ (if package (format " in package %S" package) "")
+ (if only-external-p " (external symbols only)" "")))
+
+(defun slime-apropos (string &optional only-external-p package
+ case-sensitive-p)
+ "Show all bound symbols whose names match STRING. With prefix
+arg, you're interactively asked for parameters of the search."
+ (interactive
+ (if current-prefix-arg
+ (list (read-string "SLIME Apropos: ")
+ (y-or-n-p "External symbols only? ")
+ (let ((pkg (slime-read-package-name "Package: ")))
+ (if (string= pkg "") nil pkg))
+ (y-or-n-p "Case-sensitive? "))
+ (list (read-string "SLIME Apropos: ") t nil nil)))
+ (let ((buffer-package (or package (slime-current-package))))
+ (slime-eval-async
+ `(swank:apropos-list-for-emacs ,string ,only-external-p
+ ,case-sensitive-p ',package)
+ (lexical-let ((string string)
+ (package buffer-package)
+ (summary (slime-apropos-summary string case-sensitive-p
+ package only-external-p)))
+ (lambda (r) (slime-show-apropos r string package summary))))))
+
+(defun slime-apropos-all ()
+ "Shortcut for (slime-apropos <string> nil nil)"
+ (interactive)
+ (slime-apropos (read-string "SLIME Apropos: ") nil nil))
+
+(defun slime-apropos-package (package &optional internal)
+ "Show apropos listing for symbols in PACKAGE.
+With prefix argument include internal symbols."
+ (interactive (list (let ((pkg (slime-read-package-name "Package: ")))
+ (if (string= pkg "") (slime-current-package) pkg))
+ current-prefix-arg))
+ (slime-apropos "" (not internal) package))
+
+(defun slime-show-apropos (plists string package summary)
+ (if (null plists)
+ (message "No apropos matches for %S" string)
+ (slime-with-output-to-temp-buffer ("*SLIME Apropos*" :mode apropos-mode)
+ package
+ (set-syntax-table lisp-mode-syntax-table)
+ (slime-mode t)
+ (if (boundp 'header-line-format)
+ (setq header-line-format summary)
+ (insert summary "\n\n"))
+ (slime-set-truncate-lines)
+ (slime-print-apropos plists))))
+
+(defvar slime-apropos-label-properties
+ (progn
+ (require 'apropos)
+ (cond ((and (boundp 'apropos-label-properties)
+ (symbol-value 'apropos-label-properties)))
+ ((boundp 'apropos-label-face)
+ (etypecase (symbol-value 'apropos-label-face)
+ (symbol `(face ,(or (symbol-value 'apropos-label-face)
+ 'italic)
+ mouse-face highlight))
+ (list (symbol-value 'apropos-label-face)))))))
+
+(eval-when-compile (require 'apropos))
+
+(defun slime-print-apropos (plists)
+ (dolist (plist plists)
+ (let ((designator (plist-get plist :designator)))
+ (assert designator)
+ (slime-insert-propertized `(face ,apropos-symbol-face) designator))
+ (terpri)
+ (let ((apropos-label-properties slime-apropos-label-properties))
+ (loop for (prop namespace)
+ in '((:variable "Variable")
+ (:function "Function")
+ (:generic-function "Generic Function")
+ (:macro "Macro")
+ (:special-operator "Special Operator")
+ (:setf "Setf")
+ (:type "Type")
+ (:class "Class")
+ (:alien-type "Alien type")
+ (:alien-struct "Alien struct")
+ (:alien-union "Alien type")
+ (:alien-enum "Alien enum"))
+ ;; Properties not listed here will not show up in the buffer
+ do
+ (let ((value (plist-get plist prop))
+ (start (point)))
+ (when value
+ (princ " ")
+ (slime-insert-propertized apropos-label-properties namespace)
+ (princ ": ")
+ (princ (etypecase value
+ (string value)
+ ((member :not-documented) "(not documented)")))
+ (add-text-properties
+ start (point)
+ (list 'type prop 'action 'slime-call-describer
+ 'button t 'apropos-label namespace
+ 'item (plist-get plist :designator)))
+ (terpri)))))))
+
+(defun slime-call-describer (arg)
+ (let* ((pos (if (markerp arg) arg (point)))
+ (type (get-text-property pos 'type))
+ (item (get-text-property pos 'item)))
+ (slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type))))
+
+
+;;;; XREF: cross-referencing
+
+(defvar slime-xref-mode-map)
+(defvar slime-xref-saved-emacs-snapshot nil
+ "Buffer local variable in xref windows.")
+
+(define-derived-mode slime-xref-mode lisp-mode "xref"
+ "slime-xref-mode: Major mode for cross-referencing.
+\\<slime-xref-mode-map>\
+The most important commands:
+\\[slime-xref-quit] - Dismiss buffer.
+\\[slime-show-xref] - Display referenced source and keep xref window.
+\\[slime-goto-xref] - Jump to referenced source and dismiss xref window.
+
+\\{slime-xref-mode-map}"
+ (setq font-lock-defaults nil)
+ (setq delayed-mode-hooks nil)
+ (slime-mode -1))
+
+(slime-define-keys slime-xref-mode-map
+ ((kbd "RET") 'slime-show-xref)
+ ([return] 'slime-show-xref)
+ ("\C-m" 'slime-show-xref)
+ (" " 'slime-goto-xref)
+ ("q" 'slime-xref-quit)
+ ("n" 'slime-next-line/not-add-newlines)
+ ("p" 'previous-line))
+
+(defun slime-next-line/not-add-newlines ()
+ (interactive)
+ (let ((next-line-add-newlines nil))
+ (next-line 1)))
+
+;; 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
+ (let ((key (if prefixed (concat slime-prefix-key key) key)))
+ (define-key slime-xref-mode-map key command)))))
+
+
+;;;;; XREF results buffer and window management
+
+(defun slime-xref-buffer ()
+ "Return the XREF results buffer.
+If CREATE is non-nil, create it if necessary."
+ (or (find-if (lambda (b) (string-match "*XREF\\[" (buffer-name b)))
+ (buffer-list))
+ (error "No XREF buffer")))
+
+(defun slime-init-xref-buffer (package ref-type symbol)
+ "Initialize the current buffer for displaying XREF information."
+ (slime-xref-mode)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (setq slime-buffer-package package)
+ (slime-set-truncate-lines))
+
+;; XXX: unused function
+(defun slime-display-xref-buffer ()
+ "Display the XREF results buffer in a window and select it."
+ (let* ((buffer (slime-xref-buffer))
+ (window (get-buffer-window buffer)))
+ (if (and window (window-live-p window))
+ (select-window window)
+ (select-window (display-buffer buffer t))
+ (shrink-window-if-larger-than-buffer))))
+
+(defmacro* slime-with-xref-buffer ((package ref-type symbol &key emacs-snapshot)
+ &body body)
+ "Execute BODY in a xref buffer, then show that buffer."
+ (let ((type (gensym "TYPE+")) (sym (gensym "SYM+"))
+ (pkg (gensym "PKG+")) (snapshot (gensym "SNAPSHOT+")))
+ `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package))
+ ;; We don't want the the xref buffer to be the current buffer
+ ;; in the snapshot, so we gotta take the snapshot here.
+ (let ((,snapshot (or ,emacs-snapshot (slime-current-emacs-snapshot))))
+ (with-current-buffer (get-buffer-create
+ (format "*XREF[%s: %s]*" ,type ,sym))
+ (prog2 (progn
+ (slime-init-xref-buffer ,pkg ,type ,sym)
+ (make-local-variable 'slime-xref-saved-emacs-snapshot)
+ (setq slime-xref-saved-emacs-snapshot ,snapshot))
+ (progn ,@body)
+ (setq buffer-read-only t)
+ (select-window (or (get-buffer-window (current-buffer) t)
+ (display-buffer (current-buffer) t)))
+ (shrink-window-if-larger-than-buffer)))))))
+
+(put 'slime-with-xref-buffer 'lisp-indent-function 1)
+
+(defun slime-insert-xrefs (xrefs)
+ "Insert XREFS in the current-buffer.
+XREFS is a list of the form ((GROUP . ((LABEL . LOCATION) ...)) ...)
+GROUP and LABEL are for decoration purposes. LOCATION is a source-location."
+ (unless (bobp) (insert "\n"))
+ (loop for (group . refs) in xrefs do
+ (progn
+ (slime-insert-propertized '(face bold) group "\n")
+ (loop
+ for (label . location) in refs
+ do (slime-insert-propertized
+ (list 'slime-location location
+ 'face 'font-lock-keyword-face)
+ " " (slime-one-line-ify label))
+ do (insert " - " (slime-insert-xref-location location) "\n"))))
+ ;; Remove the final newline to prevent accidental window-scrolling
+ (backward-char 1)
+ (delete-char 1))
+
+(defun slime-insert-xref-location (location)
+ (if (eql :location (car location))
+ (cond ((assoc :file (cdr location))
+ (second (assoc :file (cdr location))))
+ ((assoc :buffer (cdr location))
+ (let* ((name (second (assoc :buffer (cdr location))))
+ (buffer (get-buffer name)))
+ (if buffer
+ (format "%S" buffer)
+ (format "%s (previously existing buffer)" name)))))
+ "file unknown"))
+
+(defvar slime-next-location-function nil
+ "Function to call for going to the next location.")
+
+(defun slime-show-xrefs (xrefs type symbol package &optional emacs-snapshot)
+ "Show the results of an XREF query."
+ (if (null xrefs)
+ (message "No references found for %s." symbol)
+ (setq slime-next-location-function 'slime-goto-next-xref)
+ (slime-with-xref-buffer (package type symbol :emacs-snapshot emacs-snapshot)
+ (slime-insert-xrefs xrefs)
+ (goto-char (point-min))
+ (forward-line)
+ (skip-chars-forward " \t"))))
+
+
+;;;;; XREF commands
+
+(defun slime-who-calls (symbol)
+ "Show all known callers of the function SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who calls: " t)))
+ (slime-xref :calls symbol))
+
+(defun slime-calls-who (symbol)
+ "Show all known functions called by the function SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who calls: " t)))
+ (slime-xref :calls-who symbol))
+
+(defun slime-who-references (symbol)
+ "Show all known referrers of the global variable SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who references: " t)))
+ (slime-xref :references symbol))
+
+(defun slime-who-binds (symbol)
+ "Show all known binders of the global variable SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who binds: " t)))
+ (slime-xref :binds symbol))
+
+(defun slime-who-sets (symbol)
+ "Show all known setters of the global variable SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who sets: " t)))
+ (slime-xref :sets symbol))
+
+(defun slime-who-macroexpands (symbol)
+ "Show all known expanders of the macro SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who macroexpands: " t)))
+ (slime-xref :macroexpands symbol))
+
+(defun slime-who-specializes (symbol)
+ "Show all known methods specialized on class SYMBOL."
+ (interactive (list (slime-read-symbol-name "Who specializes: " t)))
+ (slime-xref :specializes symbol))
+
+(defun slime-list-callers (symbol-name)
+ "List the callers of SYMBOL-NAME in a xref window."
+ (interactive (list (slime-read-symbol-name "List callers: ")))
+ (slime-xref :callers symbol-name))
+
+(defun slime-list-callees (symbol-name)
+ "List the callees of SYMBOL-NAME in a xref window."
+ (interactive (list (slime-read-symbol-name "List callees: ")))
+ (slime-xref :callees symbol-name))
+
+(defun slime-xref (type symbol)
+ "Make an XREF request to Lisp."
+ (slime-eval-async
+ `(swank:xref ',type ',symbol)
+ (lexical-let ((type type)
+ (symbol symbol)
+ (package (slime-current-package))
+ ;; We have to take the snapshot here, because SLIME-EVAL-ASYNC
+ ;; is invoking its continuation within the extent of a different
+ ;; buffer. (2007-08-14)
+ (snapshot (slime-current-emacs-snapshot)))
+ (lambda (result)
+ (slime-show-xrefs result type symbol package snapshot)))))
+
+
+;;;;; XREF navigation
+
+(defun slime-xref-location-at-point ()
+ (save-excursion
+ ;; When the end of the last line is at (point-max) we can't find
+ ;; the text property there. Going to bol avoids this problem.
+ (beginning-of-line 1)
+ (or (get-text-property (point) 'slime-location)
+ (error "No reference at point."))))
+
+(defun slime-goto-xref ()
+ "Goto the cross-referenced location at point."
+ (interactive)
+ (let ((location (slime-xref-location-at-point)))
+ (slime-xref-cleanup)
+ (slime-goto-source-location location)
+ (switch-to-buffer (current-buffer))))
+
+(defun slime-show-xref ()
+ "Display the xref at point in the other window."
+ (interactive)
+ (let ((location (slime-xref-location-at-point)))
+ (slime-show-source-location location)))
+
+(defun slime-goto-next-xref ()
+ "Goto the next cross-reference location."
+ (let ((location (with-current-buffer (slime-xref-buffer)
+ (let ((w (display-buffer (current-buffer) t)))
+ (goto-char (1+ (next-single-char-property-change
+ (point) 'slime-location)))
+ (set-window-point w (point)))
+ (cond ((eobp)
+ (message "No more xrefs.")
+ nil)
+ (t
+ (slime-xref-location-at-point))))))
+ (when location
+ (slime-goto-source-location location)
+ (switch-to-buffer (current-buffer)))))
+
+(defun slime-next-location ()
+ "Go to the next location, depending on context.
+When displaying XREF information, this goes to the next reference."
+ (interactive)
+ (when (null slime-next-location-function)
+ (error "No context for finding locations."))
+ (funcall slime-next-location-function))
+
+(defun slime-xref-quit ()
+ "Kill the current xref buffer and restore the window configuration."
+ (interactive)
+ (let ((snapshot slime-xref-saved-emacs-snapshot))
+ (slime-xref-cleanup)
+ (slime-set-emacs-snapshot snapshot)))
+
+(defun slime-xref-cleanup ()
+ "Delete overlays created by xref mode and kill the xref buffer."
+ (sldb-delete-overlays)
+ (let ((buffer (current-buffer)))
+ (delete-windows-on buffer)
+ (kill-buffer buffer)))
+
+
+;;;; Macroexpansion
+
+(define-minor-mode slime-macroexpansion-minor-mode
+ "SLIME mode for macroexpansion"
+ nil
+ " temp"
+ '(("q" . slime-temp-buffer-quit)
+ ("g" . slime-macroexpand-again)))
+
+(flet ((remap (from to)
+ (dolist (mapping (where-is-internal from slime-mode-map))
+ (define-key slime-macroexpansion-minor-mode-map mapping to))))
+ (remap 'slime-macroexpand-1 'slime-macroexpand-1-inplace)
+ (remap 'slime-macroexpand-all 'slime-macroexpand-all-inplace)
+ (remap 'undo '(lambda (&optional arg)
+ (interactive)
+ (let ((buffer-read-only nil))
+ (when (fboundp 'slime-remove-edits)
+ (slime-remove-edits (point-min) (point-max)))
+ (undo arg)))))
+
+(defun slime-sexp-at-point-for-macroexpansion ()
+ "Essentially like SLIME-SEXP-AT-POINT-OR-ERROR, but behaves a
+bit more sanely in situations like ,(loop ...) where you want to
+expand the LOOP form. See comment in the source of this function."
+ (let ((string (slime-sexp-at-point-or-error))
+ (bounds (bounds-of-thing-at-point 'sexp))
+ (char-at-point (substring-no-properties (thing-at-point 'char))))
+ ;; SLIME-SEXP-AT-POINT(-OR-ERROR) uses (THING-AT-POINT 'SEXP)
+ ;; which is quite a bit botched: it returns "'(FOO BAR BAZ)" even
+ ;; when point is placed _at the opening parenthesis_, and hence
+ ;; "(FOO BAR BAZ)" wouldn't get expanded. Likewise for ",(...)",
+ ;; ",@(...)" (would return "@(...)"!!), and "\"(...)".
+ ;; So we better fix this up here:
+ (when (string= char-at-point "(")
+ (let ((char0 (elt string 0)))
+ (when (member char0 '(?\' ?\, ?\" ?\@))
+ (setf string (substring string 1))
+ (incf (car bounds)))))
+ (list string bounds)))
+
+(defvar slime-eval-macroexpand-expression nil
+ "Specifies the last macroexpansion preformed. This variable
+ specifies both what was expanded and how.")
+
+(defun slime-eval-macroexpand (expander &optional string)
+ (unless string
+ (setf string (first (slime-sexp-at-point-for-macroexpansion))))
+ (setf slime-eval-macroexpand-expression `(,expander ,string))
+ (lexical-let ((package (slime-current-package)))
+ (slime-eval-async
+ slime-eval-macroexpand-expression
+ (lambda (expansion)
+ (slime-with-output-to-temp-buffer
+ ;; reusep for preserving `undo' functionality.
+ ("*SLIME macroexpansion*" :mode lisp-mode :reusep t) package
+ (slime-macroexpansion-minor-mode)
+ (erase-buffer)
+ (insert expansion)
+ (font-lock-fontify-buffer))))))
+
+(defun slime-eval-macroexpand-inplace (expander)
+ "Substitutes the current sexp at place with its macroexpansion.
+
+NB: Does not affect *slime-eval-macroexpand-expression*"
+ (interactive)
+ (destructuring-bind (string bounds)
+ (slime-sexp-at-point-for-macroexpansion)
+ (lexical-let* ((start (car bounds))
+ (end (cdr bounds))
+ (point (point))
+ (package (slime-current-package))
+ (buffer (current-buffer)))
+ (slime-eval-async
+ `(,expander ,string)
+ (lambda (expansion)
+ (with-current-buffer buffer
+ (let ((buffer-read-only nil))
+ (when (fboundp 'slime-remove-edits)
+ (slime-remove-edits (point-min) (point-max)))
+ (goto-char start)
+ (delete-region start end)
+ (insert expansion)
+ (goto-char start)
+ (indent-sexp)
+ (goto-char point))))))))
+
+
+(defun slime-macroexpand-1 (&optional repeatedly)
+ "Display the macro expansion of the form at point. The form is
+expanded with CL:MACROEXPAND-1 or, if a prefix argument is given, with
+CL:MACROEXPAND."
+ (interactive "P")
+ (slime-eval-macroexpand
+ (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1)))
+
+(defun slime-macroexpand-1-inplace (&optional repeatedly)
+ (interactive "P")
+ (slime-eval-macroexpand-inplace
+ (if repeatedly 'swank:swank-macroexpand 'swank:swank-macroexpand-1)))
+
+(defun slime-macroexpand-all ()
+ "Display the recursively macro expanded sexp at point."
+ (interactive)
+ (slime-eval-macroexpand 'swank:swank-macroexpand-all))
+
+(defun slime-macroexpand-all-inplace ()
+ "Display the recursively macro expanded sexp at point."
+ (interactive)
+ (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all))
+
+(defun slime-compiler-macroexpand ()
+ "Display the compiler-macro expansion of sexp at point."
+ (interactive)
+ (slime-eval-macroexpand 'swank:swank-compiler-macroexpand))
+
+(defun slime-compiler-macroexpand-1 ()
+ "Display the compiler-macro expansion of sexp at point."
+ (interactive)
+ (slime-eval-macroexpand 'swank:swank-compiler-macroexpand-1))
+
+(defun slime-macroexpand-again ()
+ "Reperform the last macroexpansion."
+ (interactive)
+ (slime-eval-macroexpand (first slime-eval-macroexpand-expression)
+ (second slime-eval-macroexpand-expression)))
+
+
+;;;; Subprocess control
+
+(defun slime-interrupt ()
+ "Interrupt Lisp."
+ (interactive)
+ (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint))
+ (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread)))))
+
+(defun slime-quit ()
+ (error "Not implemented properly. Use `slime-interrupt' instead."))
+
+(defun slime-quit-lisp (&optional keep-buffers)
+ "Quit lisp, kill the inferior process and associated buffers."
+ (interactive)
+ (slime-eval-async '(swank:quit-lisp))
+ (kill-buffer (slime-output-buffer))
+ (set-process-filter (slime-connection) nil)
+ (set-process-sentinel (slime-connection) 'slime-quit-sentinel))
+
+(defun slime-quit-sentinel (process message)
+ (assert (process-status process) 'closed)
+ (let* ((inferior (slime-inferior-process process))
+ (inferior-buffer (if inferior (process-buffer inferior))))
+ (when inferior (delete-process inferior))
+ (when inferior-buffer (kill-buffer inferior-buffer))
+ (slime-net-close process)
+ (message "Connection closed.")))
+
+(defun slime-set-package (package)
+ (interactive (list (slime-read-package-name
+ "Package: " (slime-pretty-find-buffer-package))))
+ (message "*package*: %s" (slime-eval `(swank:set-package ,package))))
+
+(defun slime-set-default-directory (directory)
+ "Make DIRECTORY become Lisp's current directory."
+ (interactive (list (read-directory-name "Directory: " nil nil t)))
+ (message "default-directory: %s"
+ (slime-from-lisp-filename
+ (slime-eval `(swank:set-default-directory
+ ,(slime-to-lisp-filename directory)))))
+ (with-current-buffer (slime-output-buffer)
+ (setq default-directory (expand-file-name directory))))
+
+(defun slime-sync-package-and-default-directory ()
+ "Set Lisp's package and directory to the values in current buffer."
+ (interactive)
+ (let ((package (slime-eval `(swank:set-package
+ ,(slime-find-buffer-package))))
+ (directory (slime-from-lisp-filename
+ (slime-eval `(swank:set-default-directory
+ ,(slime-to-lisp-filename
+ default-directory))))))
+ (let ((dir default-directory))
+ ;; Sync REPL dir
+ (with-current-buffer (slime-output-buffer)
+ (setq default-directory dir))
+ ;; Sync *inferior-lisp* dir
+ (let* ((proc (slime-process))
+ (buffer (and proc (process-buffer proc))))
+ (when buffer
+ (with-current-buffer buffer
+ (setq default-directory dir)))))
+ (message "package: %s default-directory: %s" (car package) directory)))
+
+
+;;;; Debugger (SLDB)
+
+(defvar sldb-hook nil
+ "Hook run on entry to the debugger.")
+
+
+;;;;; Local variables in the debugger buffer
+
+(slime-make-variables-buffer-local
+ (defvar sldb-condition nil
+ "A list (DESCRIPTION TYPE) describing the condition being debugged.")
+
+ (defvar sldb-saved-window-configuration nil
+ "Window configuration before the debugger was initially entered.")
+
+ (defvar sldb-restarts nil
+ "List of (NAME DESCRIPTION) for each available restart.")
+
+ (defvar sldb-level nil
+ "Current debug level (recursion depth) displayed in buffer.")
+
+ (defvar sldb-backtrace-start-marker nil
+ "Marker placed at the beginning of the backtrace text.")
+
+ (defvar sldb-continuations nil
+ "List of ids for pending continuation."))
+
+;;;;; SLDB macros
+
+;; some macros that we need to define before the first use
+
+(defmacro in-sldb-face (name string)
+ "Return STRING propertised with face sldb-NAME-face."
+ (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))
+ (var (gensym "string")))
+ `(let ((,var ,string))
+ (slime-add-face ',facename ,var)
+ ,var)))
+
+(put 'in-sldb-face 'lisp-indent-function 1)
+
+(defun slime-add-face (face string)
+ (add-text-properties 0 (length string) (list 'face face) string)
+ string)
+
+
+;;;;; sldb-mode
+
+(defvar sldb-mode-syntax-table
+ (let ((table (copy-syntax-table lisp-mode-syntax-table)))
+ ;; We give < and > parenthesis syntax, so that #< ... > is treated
+ ;; as a balanced expression. This enables autodoc-mode to match
+ ;; #<unreadable> actual arguments in the backtraces with formal
+ ;; arguments of the function. (For Lisp mode, this is not
+ ;; desirable, since we do not wish to get a mismatched paren
+ ;; highlighted everytime we type < or >.)
+ (modify-syntax-entry ?< "(" table)
+ (modify-syntax-entry ?> ")" table)
+ table)
+ "Syntax table for SLDB mode.")
+
+(define-derived-mode sldb-mode fundamental-mode "sldb"
+ "Superior lisp debugger mode. In addition to ordinary SLIME commands,
+the following are available:\\<sldb-mode-map>
+
+Commands to examine the selected frame:
+ \\[sldb-toggle-details] - toggle details (local bindings, CATCH tags)
+ \\[sldb-show-source] - view source for the frame
+ \\[sldb-eval-in-frame] - eval in frame
+ \\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result
+ \\[sldb-disassemble] - disassemble
+ \\[sldb-inspect-in-frame] - inspect
+
+Commands to invoke restarts:
+ \\[sldb-quit] - quit
+ \\[sldb-abort] - abort
+ \\[sldb-continue] - continue
+ \\[sldb-invoke-restart-0]-\\[sldb-invoke-restart-9] - restart shortcuts
+
+Commands to navigate frames:
+ \\[sldb-down] - down
+ \\[sldb-up] - up
+ \\[sldb-details-down] - down, with details
+ \\[sldb-details-up] - up, with details
+
+Miscellaneous commands:
+ \\[sldb-restart-frame] - restart frame
+ \\[sldb-return-from-frame] - return from frame
+ \\[sldb-step] - step
+ \\[sldb-break-with-default-debugger] - switch to default debugger
+ \\[slime-interactive-eval] - eval
+
+Full list of commands:
+
+\\{sldb-mode-map}"
+ (erase-buffer)
+ (set-syntax-table sldb-mode-syntax-table)
+ (slime-set-truncate-lines)
+ ;; Make original slime-connection "sticky" for SLDB commands in this buffer
+ (setq slime-buffer-connection (slime-connection))
+ (add-local-hook 'kill-buffer-hook 'sldb-delete-overlays)
+ (add-local-hook 'kill-buffer-hook 'sldb-quit))
+
+(slime-define-keys sldb-mode-map
+ ("h" 'describe-mode)
+ ("v" 'sldb-show-source)
+ ((kbd "RET") 'sldb-default-action)
+ ("\C-m" 'sldb-default-action)
+ ([return] 'sldb-default-action)
+ ([mouse-2] 'sldb-default-action/mouse)
+ ([follow-link] 'mouse-face)
+ ("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)
+ ("<" 'sldb-beginning-of-backtrace)
+ (">" 'sldb-end-of-backtrace)
+ ("t" 'sldb-toggle-details)
+ ("r" 'sldb-restart-frame)
+ ("R" 'sldb-return-from-frame)
+ ("c" 'sldb-continue)
+ ("s" 'sldb-step)
+ ("x" 'sldb-next)
+ ("o" 'sldb-out)
+ ("b" 'sldb-break-on-return)
+ ("a" 'sldb-abort)
+ ("q" 'sldb-quit)
+ ("B" 'sldb-break-with-default-debugger)
+ ("P" 'sldb-print-condition)
+ ("C" 'sldb-inspect-condition)
+ (":" 'slime-interactive-eval)
+ ("\C-c\C-d" slime-doc-map))
+
+;; 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)))
+ (docstring (format "Invoke restart numbered %S." number)))
+ `(progn
+ (defun ,fname ()
+ ,docstring
+ (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
+
+(defun sldb-buffers ()
+ "Return a list of all sldb buffers."
+ (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode))))
+
+(defun sldb-find-buffer (thread &optional connection)
+ (let ((connection (or connection (slime-connection))))
+ (find-if (lambda (buffer)
+ (with-current-buffer buffer
+ (and (eq slime-buffer-connection connection)
+ (eq slime-current-thread thread))))
+ (sldb-buffers))))
+
+(defun sldb-get-default-buffer ()
+ "Get a sldb buffer.
+The buffer is chosen more or less randomly."
+ (car (sldb-buffers)))
+
+(defun sldb-get-buffer (thread &optional connection)
+ "Find or create a sldb-buffer for THREAD."
+ (let ((connection (or connection (slime-connection))))
+ (or (sldb-find-buffer thread connection)
+ (let ((name (format "*sldb %s/%s*" (slime-connection-name) thread)))
+ (with-current-buffer (generate-new-buffer name)
+ (setq slime-buffer-connection connection
+ slime-current-thread thread)
+ (current-buffer))))))
+
+(defun sldb-debugged-continuations (connection)
+ "Return the debugged continuations for CONNECTION."
+ (lexical-let ((accu '()))
+ (dolist (b (sldb-buffers))
+ (with-current-buffer b
+ (when (eq slime-buffer-connection connection)
+ (setq accu (append sldb-continuations accu)))))
+ accu))
+
+(defun sldb-setup (thread level condition restarts frames conts)
+ "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.
+CONTS is a list of pending Emacs continuations."
+ (with-current-buffer (sldb-get-buffer thread)
+ (unless (equal sldb-level level)
+ (setq buffer-read-only nil)
+ (sldb-mode)
+ (unless sldb-saved-window-configuration
+ (setq sldb-saved-window-configuration (current-window-configuration)))
+ (setq slime-current-thread thread)
+ (setq sldb-level level)
+ (setq mode-name (format "sldb[%d]" sldb-level))
+ (setq sldb-condition condition)
+ (setq sldb-restarts restarts)
+ (setq sldb-continuations conts)
+ (sldb-insert-condition condition)
+ (insert "\n\n" (in-sldb-face section "Restarts:") "\n")
+ (sldb-insert-restarts restarts)
+ (insert "\n" (in-sldb-face section "Backtrace:") "\n")
+ (setq sldb-backtrace-start-marker (point-marker))
+ (save-excursion
+ (sldb-insert-frames (sldb-prune-initial-frames frames) t))
+ (run-hooks 'sldb-hook)
+ (pop-to-buffer (current-buffer))
+ (sldb-recenter-region (point-min) (point))
+ (setq buffer-read-only t)
+ (when (and slime-stack-eval-tags
+ ;; (y-or-n-p "Enter recursive edit? ")
+ )
+ (message "Entering recursive edit..")
+ (recursive-edit)))))
+
+(defun sldb-activate (thread level)
+ "Display the debugger buffer for THREAD.
+If LEVEL isn't the same as in the buffer, reinitialize the buffer."
+ (unless (let ((b (sldb-find-buffer thread)))
+ (and b (with-current-buffer b (equal sldb-level level))))
+ (slime-rex (thread level)
+ ('(swank:debugger-info-for-emacs 0 10)
+ nil thread)
+ ((:ok result)
+ (apply #'sldb-setup thread level result)))))
+
+(defun sldb-exit (thread level &optional stepping)
+ "Exit from the debug level LEVEL."
+ (when-let (sldb (sldb-find-buffer thread))
+ (with-current-buffer sldb
+ (unless stepping
+ (set-window-configuration sldb-saved-window-configuration))
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (setq sldb-level nil))
+ (when (and (= level 1) (not stepping))
+ (kill-buffer sldb))))
+
+(defun sldb-insert-condition (condition)
+ "Insert the text for CONDITION.
+CONDITION should be a list (MESSAGE TYPE EXTRAS).
+EXTRAS is currently used for the stepper."
+ (destructuring-bind (message type extras) condition
+ (when (> (length message) 70)
+ (add-text-properties 0 (length message) (list 'help-echo message)
+ message))
+ (slime-insert-propertized '(sldb-default-action sldb-inspect-condition)
+ (in-sldb-face topline message)
+ "\n"
+ (in-sldb-face condition type))
+ (sldb-dispatch-extras extras)))
+
+(defvar sldb-extras-hooks)
+
+(defun sldb-dispatch-extras (extras)
+ ;; this is (mis-)used for the stepper
+ (dolist (extra extras)
+ (destructure-case extra
+ ((:show-frame-source n)
+ (sldb-show-frame-source n))
+ (t
+ (or (run-hook-with-args-until-success 'sldb-extras-hooks extra)
+ ;;(error "Unhandled extra element:" extra)
+ )))))
+
+(defun sldb-insert-restarts (restarts)
+ "Insert RESTARTS and add the needed text props
+RESTARTS should be alist ((NAME DESCRIPTION) ...)."
+ (loop for (name string) in restarts
+ for number from 0 do
+ (insert " ")
+ (slime-insert-propertized
+ `(,@nil 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-prune-initial-frames (frames)
+ "Return the prefix of FRAMES to initially present to the user.
+Regexp heuristics are used to avoid showing SWANK-internal frames."
+ (let* ((case-fold-search t)
+ (rx "^\\([() ]\\|lambda\\)*swank\\>"))
+ (or (loop for frame in frames
+ for (_ string) = frame
+ until (string-match rx string)
+ collect frame)
+ frames)))
+
+(defun sldb-insert-frames (frames more)
+ "Insert FRAMES into buffer.
+If MORE is non-nil, more frames are on the Lisp stack."
+ (mapc #'sldb-insert-frame frames)
+ (when more
+ (destructuring-bind ((num _)) (last frames)
+ (slime-insert-propertized
+ `(,@nil sldb-default-action sldb-fetch-more-frames
+ sldb-previous-frame-number ,num
+ point-entered sldb-fetch-more-frames
+ start-open t
+ face sldb-section-face
+ mouse-face highlight)
+ " --more--")
+ (insert "\n"))))
+
+(defun sldb-insert-frame (frame &optional face)
+ "Insert FRAME with FACE at point.
+If FACE is nil use `sldb-frame-line-face'."
+ (destructuring-bind (number string) frame
+ (let ((props `(frame ,frame sldb-default-action sldb-toggle-details)))
+ (slime-propertize-region props
+ (slime-propertize-region '(mouse-face highlight)
+ (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ")
+ (slime-insert-indented
+ (slime-add-face (or face 'sldb-frame-line-face)
+ string)))
+ (insert "\n")))))
+
+(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)
+ (inhibit-read-only t)
+ (prev (get-text-property (point) 'sldb-previous-frame-number)))
+ ;; for unkown reasons, PREV is sometimes nil
+ (when prev
+ (let* ((count 40)
+ (from (1+ prev))
+ (to (+ from count))
+ (frames (slime-eval `(swank:backtrace ,from ,to)))
+ (more (slime-length= frames count))
+ (pos (point)))
+ (delete-region (line-beginning-position) (point-max))
+ (sldb-insert-frames frames more)
+ (goto-char pos)))))
+
+
+;;;;;; SLDB examining text props
+
+(defun sldb-restart-at-point ()
+ (or (get-text-property (point) 'restart-number)
+ (error "No restart at point")))
+
+(defun sldb-frame-number-at-point ()
+ (let ((frame (get-text-property (point) 'frame)))
+ (cond (frame (car frame))
+ (t (error "No frame at point")))))
+
+(defun sldb-var-number-at-point ()
+ (let ((var (get-text-property (point) 'var)))
+ (cond (var var)
+ (t (error "No variable at point")))))
+
+(defun sldb-previous-frame-number ()
+ (save-excursion
+ (sldb-backward-frame)
+ (sldb-frame-number-at-point)))
+
+(defun sldb-frame-details-visible-p ()
+ (and (get-text-property (point) 'frame)
+ (get-text-property (point) 'details-visible-p)))
+
+(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-forward-frame ()
+ (goto-char (next-single-char-property-change (point) 'frame)))
+
+(defun sldb-backward-frame ()
+ (goto-char (previous-single-char-property-change
+ (car (sldb-frame-region))
+ 'frame
+ nil sldb-backtrace-start-marker)))
+
+(defun sldb-goto-last-frame ()
+ (goto-char (point-max))
+ (while (not (get-text-property (point) 'frame))
+ (goto-char (previous-single-property-change (point) 'frame))))
+
+(defun sldb-beginning-of-backtrace ()
+ "Goto the first frame."
+ (interactive)
+ (goto-char sldb-backtrace-start-marker))
+
+
+;;;;;; SLDB recenter & redisplay
+
+;; FIXME: these functions need factorization
+
+(defvar sldb-show-location-recenter-arg nil
+ "Argument to pass to `recenter' when displaying a source location.")
+
+(defun slime-show-buffer-position (position)
+ "Ensure sure that the POSITION in the current buffer is visible."
+ (save-selected-window
+ (let ((w (select-window (or (get-buffer-window (current-buffer) t)
+ (display-buffer (current-buffer) t)))))
+ (goto-char position)
+ (push-mark)
+ (unless (pos-visible-in-window-p)
+ (slime-recenter-window w sldb-show-location-recenter-arg)))))
+
+(defun slime-recenter-window (window line)
+ "Set window-start in WINDOW LINE lines before point."
+ (let* ((line (if (not line)
+ (/ (window-height window) 2)
+ line))
+ (start (save-excursion
+ (loop repeat line do (forward-line -1))
+ (point))))
+ (set-window-start window start)))
+
+(defun sldb-recenter-region (start end &optional center)
+ "Make the region from START to END visible.
+Avoid point motions, if possible.
+Minimize scrolling, if CENTER is nil.
+If CENTER is true, scroll enough to center the region in the window."
+ (let ((pos (point)) (lines (count-screen-lines start end t)))
+ (assert (and (<= start pos) (<= pos end)))
+ ;;(sit-for 0)
+ (cond ((and (pos-visible-in-window-p start)
+ (pos-visible-in-window-p end)))
+ ((< lines (window-height))
+ (cond (center (recenter (+ (/ (- (window-height) 1 lines)
+ 2)
+ (slime-count-lines start pos))))
+ (t (recenter (+ (- (window-height) 1 lines)
+ (slime-count-lines start pos))))))
+ (t
+ (goto-char start)
+ (recenter 0)
+ (cond ((pos-visible-in-window-p pos)
+ (goto-char pos))
+ (t
+ (goto-char start)
+ (next-line (- (window-height) 2))))))))
+
+;; not sure yet, whether this is a good idea.
+(defmacro slime-save-coordinates (origin &rest body)
+ "Restore line and column relative to ORIGIN, after executing BODY.
+
+This is useful if BODY deletes and inserts some text but we want to
+preserve the current row and column as closely as possible."
+ (let ((base (make-symbol "base"))
+ (goal (make-symbol "goal"))
+ (mark (make-symbol "mark")))
+ `(let* ((,base ,origin)
+ (,goal (slime-coordinates ,base))
+ (,mark (point-marker)))
+ (set-marker-insertion-type ,mark t)
+ (prog1 (save-excursion ,@body)
+ (slime-restore-coordinate ,base ,goal ,mark)))))
+
+(put 'slime-save-coordinates 'lisp-indent-function 1)
+
+(defun slime-coordinates (origin)
+ ;; Return a pair (X . Y) for the column and line distance to ORIGIN.
+ (let ((y (slime-count-lines origin (point)))
+ (x (save-excursion
+ (- (current-column)
+ (progn (goto-char origin) (current-column))))))
+ (cons x y)))
+
+(defun slime-restore-coordinate (base goal limit)
+ ;; Move point to GOAL. Coordinates are relative to BASE.
+ ;; Don't move beyond LIMIT.
+ (save-restriction
+ (narrow-to-region base limit)
+ (goto-char (point-min))
+ (let ((col (current-column)))
+ (forward-line (cdr goal))
+ (when (and (eobp) (bolp) (not (bobp)))
+ (backward-char))
+ (move-to-column (+ col (car goal))))))
+
+(defun slime-count-lines (start end)
+ "Return the number of lines between START and END.
+This is 0 if START and END at the same line."
+ (- (count-lines start end)
+ (if (save-excursion (goto-char end) (bolp)) 0 1)))
+
+
+;;;;; SLDB commands
+
+(defun sldb-default-action ()
+ "Invoke the action at point."
+ (interactive)
+ (let ((fn (get-text-property (point) 'sldb-default-action)))
+ (if fn (funcall fn))))
+
+(defun sldb-default-action/mouse (event)
+ "Invoke the action pointed at by the mouse."
+ (interactive "e")
+ (destructuring-bind (mouse-1 (w pos &rest _)) event
+ (save-excursion
+ (goto-char pos)
+ (let ((fn (get-text-property (point) 'sldb-default-action)))
+ (if fn (funcall fn))))))
+
+(defun sldb-end-of-backtrace ()
+ "Fetch the entire backtrace and go to the last frame."
+ (interactive)
+ (sldb-fetch-all-frames)
+ (sldb-goto-last-frame))
+
+(defun sldb-fetch-all-frames ()
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t))
+ (sldb-goto-last-frame)
+ (let ((last (sldb-frame-number-at-point)))
+ (goto-char (next-single-char-property-change (point) 'frame))
+ (delete-region (point) (point-max))
+ (save-excursion
+ (sldb-insert-frames (slime-eval `(swank:backtrace ,(1+ last) nil))
+ nil)))))
+
+
+;;;;;; SLDB show source
+
+(defvar sldb-overlays '()
+ "List of overlays created in source code buffers to highlight expressions.")
+
+(defun sldb-show-source ()
+ "Highlight the frame at point's expression in a source code buffer."
+ (interactive)
+ (sldb-show-frame-source (sldb-frame-number-at-point)))
+
+(defun sldb-show-frame-source (frame-number)
+ (sldb-delete-overlays)
+ (slime-eval-async
+ `(swank:frame-source-location-for-emacs ,frame-number)
+ (lambda (source-location)
+ (destructure-case source-location
+ ((:error message)
+ (message "%s" message)
+ (ding))
+ (t
+ (slime-show-source-location source-location))))))
+
+(defun slime-show-source-location (source-location &optional no-highlight-p)
+ (slime-goto-source-location source-location)
+ (unless no-highlight-p (sldb-highlight-sexp))
+ (slime-show-buffer-position (point)))
+
+(defun sldb-highlight-sexp (&optional start end)
+ "Highlight the first sexp after point."
+ (sldb-delete-overlays)
+ (let ((start (or start (point)))
+ (end (or end (save-excursion (ignore-errors (forward-sexp)) (point)))))
+ (push (make-overlay start (1+ start)) sldb-overlays)
+ (push (make-overlay (1- end) end) sldb-overlays))
+ (dolist (overlay sldb-overlays)
+ (overlay-put overlay 'face 'secondary-selection)))
+
+(defun sldb-delete-overlays ()
+ (mapc #'delete-overlay sldb-overlays)
+ (setq sldb-overlays '()))
+
+
+;;;;;; SLDB toggle details
+
+(defun sldb-toggle-details (&optional on)
+ "Toggle display of details for the current frame.
+The details include local variable bindings and CATCH-tags."
+ (interactive)
+ (assert (sldb-frame-number-at-point))
+ (let ((inhibit-read-only t))
+ (if (or on (not (sldb-frame-details-visible-p)))
+ (sldb-show-frame-details)
+ (sldb-hide-frame-details))))
+
+(defun sldb-show-frame-details ()
+ ;; fetch and display info about local variables and catch tags
+ (destructuring-bind (start end frame locals catches) (sldb-frame-details)
+ (slime-save-coordinates start
+ (delete-region start end)
+ (slime-propertize-region `(frame ,frame details-visible-p t)
+ (sldb-insert-frame frame 'sldb-detailed-frame-line-face)
+ (let ((indent1 " ")
+ (indent2 " "))
+ (insert indent1 (in-sldb-face section
+ (if locals "Locals:" "[No Locals]")) "\n")
+ (sldb-insert-locals locals indent2 frame)
+ (when catches
+ (insert indent1 (in-sldb-face section "Catch-tags:") "\n")
+ (dolist (tag catches)
+ (slime-propertize-region `(catch-tag ,tag)
+ (insert indent2 (in-sldb-face catch-tag (format "%s" tag))
+ "\n"))))
+ (setq end (point)))))
+ (sldb-recenter-region start end)))
+
+(defun sldb-frame-details ()
+ ;; Return a list (START END FRAME LOCALS CATCHES) for frame at point.
+ (let* ((frame (get-text-property (point) 'frame))
+ (num (car frame))
+ (catches (sldb-catch-tags num))
+ (locals (sldb-frame-locals num)))
+ (destructuring-bind (start end) (sldb-frame-region)
+ (list start end frame locals catches))))
+
+(defun sldb-insert-locals (vars prefix frame)
+ "Insert VARS and add PREFIX at the beginning of each inserted line.
+VAR should be a plist with the keys :name, :id, and :value."
+ (loop for i from 0
+ for var in vars do
+ (destructuring-bind (&key name id value) var
+ (slime-propertize-region (list 'sldb-default-action 'sldb-inspect-var
+ 'var i)
+ (insert prefix
+ (in-sldb-face local-name
+ (concat name (if (zerop id) "" (format "#%d" id))))
+ " = ")
+ (insert (in-sldb-face local-value value) "\n")))))
+
+(defun sldb-hide-frame-details ()
+ ;; delete locals and catch tags, but keep the function name and args.
+ (destructuring-bind (start end) (sldb-frame-region)
+ (let ((frame (get-text-property (point) 'frame)))
+ (slime-save-coordinates start
+ (delete-region start end)
+ (slime-propertize-region '(details-visible-p nil)
+ (sldb-insert-frame frame))))))
+
+(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)
+ (lambda (result)
+ (slime-show-description result nil)))))
+
+(defun sldb-print-condition ()
+ "Print the condition SLDB is handling in the REPL.
+This way you can still see what the error was after exiting SLDB."
+ (interactive)
+ (unless sldb-condition
+ (error "No condition known (wrong buffer?)"))
+ (slime-write-string (format "%s\n%s\n"
+ (first sldb-condition)
+ (second sldb-condition))))
+
+(defun sldb-frame-locals (frame)
+ (slime-eval `(swank:frame-locals-for-emacs ,frame)))
+
+(defun sldb-catch-tags (frame)
+ (slime-eval `(swank:frame-catch-tags-for-emacs ,frame)))
+
+
+;;;;;; SLDB eval and inspect
+
+(defun sldb-eval-in-frame (string)
+ "Prompt for an expression and evaluate it in the selected frame."
+ (interactive (list (slime-read-from-minibuffer "Eval in frame: ")))
+ (let* ((number (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:eval-string-in-frame ,string ,number)
+ (if current-prefix-arg
+ 'slime-write-string
+ 'slime-display-eval-result))))
+
+(defun sldb-pprint-eval-in-frame (string)
+ "Prompt for an expression, evaluate in selected frame, pretty-print result."
+ (interactive (list (slime-read-from-minibuffer "Eval in frame: ")))
+ (let* ((number (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:pprint-eval-string-in-frame ,string ,number)
+ (lambda (result)
+ (slime-show-description result nil)))))
+
+
+
+(defun sldb-inspect-in-frame (string)
+ "Prompt for an expression and inspect it in the selected frame."
+ (interactive (list (slime-read-from-minibuffer
+ "Inspect in frame (evaluated): "
+ (slime-sexp-at-point))))
+ (let ((number (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:inspect-in-frame ,string ,number)
+ 'slime-open-inspector)))
+
+(defun sldb-inspect-var ()
+ (let ((frame (sldb-frame-number-at-point))
+ (var (sldb-var-number-at-point)))
+ (slime-eval-async `(swank:inspect-frame-var ,frame ,var)
+ 'slime-open-inspector)))
+
+(defun sldb-inspect-condition ()
+ "Inspect the current debugger condition."
+ (interactive)
+ (slime-eval-async '(swank:inspect-current-condition)
+ 'slime-open-inspector))
+
+
+;;;;;; SLDB movement
+
+(defun sldb-down ()
+ "Select next frame."
+ (interactive)
+ (sldb-forward-frame))
+
+(defun sldb-up ()
+ "Select previous frame."
+ (interactive)
+ (sldb-backward-frame)
+ (when (= (point) sldb-backtrace-start-marker)
+ (recenter (1+ (count-lines (point-min) (point))))))
+
+(defun sldb-sugar-move (move-fn)
+ (let ((inhibit-read-only t))
+ (when (sldb-frame-details-visible-p) (sldb-hide-frame-details))
+ (funcall move-fn)
+ (sldb-show-source)
+ (sldb-toggle-details t)))
+
+(defun sldb-details-up ()
+ "Select previous frame and show details."
+ (interactive)
+ (sldb-sugar-move 'sldb-up))
+
+(defun sldb-details-down ()
+ "Select next frame and show details."
+ (interactive)
+ (sldb-sugar-move 'sldb-down))
+
+
+;;;;;; SLDB restarts
+
+(defun sldb-quit ()
+ "Quit to toplevel."
+ (interactive)
+ (slime-rex () ('(swank:throw-to-toplevel))
+ ((:ok _) (error "sldb-quit returned"))
+ ((:abort))))
+
+(defun sldb-continue ()
+ "Invoke the \"continue\" restart."
+ (interactive)
+ (slime-rex ()
+ ('(swank:sldb-continue))
+ ((:ok _)
+ (message "No restart named continue")
+ (ding))
+ ((:abort))))
+
+(defun sldb-abort ()
+ "Invoke the \"abort\" restart."
+ (interactive)
+ (slime-eval-async '(swank:sldb-abort)
+ (lambda (v) (message "Restart returned: %S" v))))
+
+(defun sldb-invoke-restart (&optional number)
+ "Invoke a restart.
+Optional NUMBER specifies the restart to invoke, otherwise
+use the restart at point."
+ (interactive)
+ (let ((restart (or number (sldb-restart-at-point))))
+ (slime-rex ()
+ ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart))
+ ((:ok value) (message "Restart returned: %s" value))
+ ((:abort)))))
+
+(defun sldb-break-with-default-debugger ()
+ "Enter default debugger."
+ (interactive)
+ (slime-rex ()
+ ('(swank:sldb-break-with-default-debugger) nil slime-current-thread)
+ ((:abort))))
+
+(defun sldb-step ()
+ "Select the \"continue\" restart and set a new break point."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-step ,frame))))
+
+(defun sldb-next ()
+ "Select the \"continue\" restart and set a new break point."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-next ,frame))))
+
+(defun sldb-out ()
+ "Select the \"continue\" restart and set a new break point."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-out ,frame))))
+
+(defun sldb-break-on-return ()
+ "Set a breakpoint at the current frame.
+The debugger is entered when the frame exits."
+ (interactive)
+ (let ((frame (sldb-frame-number-at-point)))
+ (slime-eval-async `(swank:sldb-break-on-return ,frame)
+ (lambda (msg) (message "%s" msg)))))
+
+(defun sldb-break (name)
+ "Set a breakpoint at the start of the function NAME."
+ (interactive (list (slime-read-symbol-name "Function: " t)))
+ (slime-eval-async `(swank:sldb-break ,name)
+ (lambda (msg) (message "%s" msg))))
+
+(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-rex ()
+ ((list 'swank:sldb-return-from-frame number string))
+ ((:ok value) (message "%s" value))
+ ((:abort)))))
+
+(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-rex ()
+ ((list 'swank:restart-frame number))
+ ((:ok value) (message "%s" value))
+ ((:abort)))))
+
+
+;;;; Thread control panel
+
+(defun slime-list-threads ()
+ "Display a list of threads."
+ (interactive)
+ (let ((threads (slime-eval '(swank:list-threads))))
+ (with-current-buffer (get-buffer-create "*slime-threads*")
+ (slime-thread-control-mode)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (loop for idx from 0
+ for (name status id) in threads
+ do (slime-thread-insert idx name status id))
+ (goto-char (point-min))
+ (setq buffer-read-only t)
+ (pop-to-buffer (current-buffer))))))
+
+(defun slime-thread-insert (idx name summary id)
+ (slime-propertize-region `(thread-id ,idx)
+ (insert (format "%3s: " id))
+ (slime-insert-propertized '(face bold) name)
+ (insert-char ?\ (- 30 (current-column)))
+ (let ((summary-start (point)))
+ (insert " " summary)
+ (unless (bolp) (insert "\n"))
+ (indent-rigidly summary-start (point) 2))))
+
+
+;;;;; Major mode
+
+(define-derived-mode slime-thread-control-mode fundamental-mode
+ "thread-control"
+ "SLIME Thread Control Panel Mode.
+
+\\{slime-thread-control-mode-map}"
+ (when slime-truncate-lines
+ (set (make-local-variable 'truncate-lines) t)))
+
+(slime-define-keys slime-thread-control-mode-map
+ ("a" 'slime-thread-attach)
+ ("d" 'slime-thread-debug)
+ ("g" 'slime-list-threads)
+ ("k" 'slime-thread-kill)
+ ("q" 'slime-thread-quit))
+
+(defun slime-thread-quit ()
+ (interactive)
+ (slime-eval-async `(swank:quit-thread-browser))
+ (kill-buffer (current-buffer)))
+
+(defun slime-thread-kill ()
+ (interactive)
+ (let ((id (get-text-property (point) 'thread-id)))
+ (slime-eval `(swank:kill-nth-thread ,id)))
+ (call-interactively 'slime-list-threads))
+
+(defun slime-thread-attach ()
+ (interactive)
+ (let ((id (get-text-property (point) 'thread-id))
+ (file (slime-swank-port-file)))
+ (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file)))
+ (slime-read-port-and-connect nil nil))
+
+(defun slime-thread-debug ()
+ (interactive)
+ (let ((id (get-text-property (point) 'thread-id)))
+ (slime-eval-async `(swank:debug-nth-thread ,id))))
+
+
+;;;;; Connection listing
+
+(define-derived-mode slime-connection-list-mode fundamental-mode
+ "connection-list"
+ "SLIME Connection List Mode.
+
+\\{slime-connection-list-mode-map}"
+ (when slime-truncate-lines
+ (set (make-local-variable 'truncate-lines) t)))
+
+(slime-define-keys slime-connection-list-mode-map
+ ((kbd "RET") 'slime-goto-connection)
+ ([return] 'slime-goto-connection)
+ ("d" 'slime-connection-list-make-default)
+ ("g" 'slime-update-connection-list)
+ ((kbd "C-k") 'slime-quit-connection-at-point)
+ ("R" 'slime-restart-connection-at-point))
+
+(defun slime-connection-at-point ()
+ (or (get-text-property (point) 'slime-connection)
+ (error "No connection at point")))
+
+(defun slime-goto-connection ()
+ "Switch to the REPL buffer for the connection at point."
+ (interactive)
+ (let ((slime-dispatching-connection (slime-connection-at-point)))
+ (switch-to-buffer (slime-output-buffer))))
+
+(defun slime-quit-connection-at-point (connection)
+ (interactive (list (slime-connection-at-point)))
+ (let ((slime-dispatching-connection connection))
+ (slime-quit-lisp)
+ (while (memq connection slime-net-processes)
+ (sit-for 0 100)))
+ (slime-update-connection-list))
+
+(defun slime-restart-connection-at-point (connection)
+ (interactive (list (slime-connection-at-point)))
+ (let ((slime-dispatching-connection connection))
+ (slime-restart-inferior-lisp)))
+
+(defun slime-connection-list-make-default ()
+ "Make the connection at point the default connection."
+ (interactive)
+ (slime-select-connection (slime-connection-at-point))
+ (slime-update-connection-list))
+
+(defun slime-list-connections ()
+ "Display a list of all connections."
+ (interactive)
+ (when (get-buffer "*SLIME connections*")
+ (kill-buffer "*SLIME connections*"))
+ (with-current-buffer
+ (slime-get-temp-buffer-create "*SLIME connections*"
+ :mode 'slime-connection-list-mode)
+ (slime-draw-connection-list)
+ (setq buffer-read-only t)
+ (pop-to-buffer (current-buffer))))
+
+(defun slime-update-connection-list ()
+ "Display a list of all connections."
+ (interactive)
+ (let ((pos (point))
+ (inhibit-read-only t))
+ (erase-buffer)
+ (slime-draw-connection-list)
+ (goto-char pos)))
+
+(defun slime-draw-connection-list ()
+ (let ((default-pos nil)
+ (default slime-default-connection)
+ (fstring "%s%2s %-10s %-17s %-7s %-s\n"))
+ (insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type")
+ (format fstring " " "--" "----" "----" "---" "----"))
+ (dolist (p (reverse slime-net-processes))
+ (when (eq default p) (setf default-pos (point)))
+ (slime-insert-propertized
+ (list 'slime-connection p)
+ (format fstring
+ (if (eq default p) "*" " ")
+ (slime-connection-number p)
+ (slime-connection-name p)
+ (or (process-id p) (process-contact p))
+ (slime-pid p)
+ (slime-lisp-implementation-type p))))
+ (when default
+ (goto-char default-pos))))
+
+
+;;;; Inspector
+
+(defgroup slime-inspector nil
+ "Inspector faces."
+ :prefix "slime-inspector-"
+ :group 'slime)
+
+(defface slime-inspector-topline-face
+ '((t ()))
+ "Face for top line describing object."
+ :group 'slime-inspector)
+
+(defface slime-inspector-label-face
+ '((t (:inherit font-lock-constant-face)))
+ "Face for labels in the inspector."
+ :group 'slime-inspector)
+
+(defface slime-inspector-value-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit font-lock-builtin-face)))
+ '((((background light)) (:foreground "MediumBlue" :bold t))
+ (((background dark)) (:foreground "LightGray" :bold t))))
+ "Face for things which can themselves be inspected."
+ :group 'slime-inspector)
+
+(defface slime-inspector-action-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit font-lock-warning-face)))
+ '((t (:foreground "OrangeRed"))))
+ "Face for labels of inspector actions."
+ :group 'slime-inspector)
+
+(defface slime-inspector-type-face
+ '((t (:inherit font-lock-type-face)))
+ "Face for type description in inspector."
+ :group 'slime-inspector)
+
+(defvar slime-inspector-mark-stack '())
+(defvar slime-saved-window-config)
+
+(defun slime-inspect (string)
+ "Eval an expression and inspect the result."
+ (interactive
+ (list (slime-read-from-minibuffer "Inspect value (evaluated): "
+ (slime-sexp-at-point))))
+ (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector))
+
+(define-derived-mode slime-inspector-mode fundamental-mode "Slime-Inspector"
+ (set-syntax-table lisp-mode-syntax-table)
+ (slime-set-truncate-lines)
+ (setq buffer-read-only t))
+
+(defun slime-inspector-buffer ()
+ (or (get-buffer "*Slime Inspector*")
+ (with-current-buffer (get-buffer-create "*Slime Inspector*")
+ (setq slime-inspector-mark-stack '())
+ (buffer-disable-undo)
+ (slime-mode t)
+ (slime-inspector-mode)
+ (make-local-variable 'slime-saved-window-config)
+ (setq slime-saved-window-config (current-window-configuration))
+ (current-buffer))))
+
+(defmacro slime-inspector-fontify (face string)
+ `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string))
+
+(defun slime-open-inspector (inspected-parts &optional point)
+ "Display INSPECTED-PARTS in a new inspector window.
+Optionally set point to POINT."
+ (with-current-buffer (slime-inspector-buffer)
+ (setq slime-buffer-connection (slime-current-connection))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (destructuring-bind (&key id title content) inspected-parts
+ (macrolet ((fontify (face string)
+ `(slime-inspector-fontify ,face ,string)))
+ (slime-propertize-region
+ (list 'slime-part-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-value-face)
+ (insert title))
+ (while (eq (char-before) ?\n)
+ (backward-delete-char 1))
+ (insert "\n" (fontify label "--------------------") "\n")
+ (save-excursion
+ (mapc #'slime-inspector-insert-ispec content))
+ (pop-to-buffer (current-buffer))
+ (when point
+ (check-type point cons)
+ (ignore-errors
+ (goto-line (car point))
+ (move-to-column (cdr point)))))))))
+
+(defun slime-inspector-insert-ispec (ispec)
+ (if (stringp ispec)
+ (insert ispec)
+ (destructure-case ispec
+ ((:value string id)
+ (slime-propertize-region
+ (list 'slime-part-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-value-face)
+ (insert string)))
+ ((:action string id)
+ (slime-insert-propertized (list 'slime-action-number id
+ 'mouse-face 'highlight
+ 'face 'slime-inspector-action-face)
+ string)))))
+
+(defun slime-inspector-position ()
+ "Return a pair (Y-POSITION X-POSITION) representing the
+position of point in the current buffer."
+ ;; We make sure we return absolute coordinates even if the user has
+ ;; narrowed the buffer.
+ (save-restriction
+ (widen)
+ (cons (cond ((fboundp 'line-number)
+ (line-number)) ; XEmacs
+ ((fboundp 'line-number-at-pos)
+ (line-number-at-pos)) ; Recent GNU Emacs
+ (t (1+ (count-lines 1 (point-at-bol)))))
+ (current-column))))
+
+(defun slime-inspector-operate-on-point ()
+ "If point is on a value then recursivly call the inspector on
+ that value. If point is on an action then call that action."
+ (interactive)
+ (let ((part-number (get-text-property (point) 'slime-part-number))
+ (action-number (get-text-property (point) 'slime-action-number))
+ (opener (lexical-let ((point (slime-inspector-position)))
+ (lambda (parts)
+ (when parts
+ (slime-open-inspector parts point))))))
+ (cond (part-number
+ (slime-eval-async `(swank:inspect-nth-part ,part-number)
+ opener)
+ (push (slime-inspector-position) slime-inspector-mark-stack))
+ (action-number
+ (slime-eval-async `(swank::inspector-call-nth-action ,action-number)
+ opener)))))
+
+(defun slime-inspector-operate-on-click (event)
+ "Inspect the value at the clicked-at position or invoke an action."
+ (interactive "@e")
+ (let ((point (posn-point (event-end event))))
+ (cond ((and point
+ (or (get-text-property point 'slime-part-number)
+ (get-text-property point 'slime-action-number)))
+ (goto-char point)
+ (slime-inspector-operate-on-point))
+ (t
+ (error "No clickable part here")))))
+
+(defun slime-inspector-copy-down (number)
+ "Evaluate the slot at point via the REPL (to set `*')."
+ (interactive (list (or (get-text-property (point) 'slime-part-number)
+ (error "No part at point"))))
+ (slime-repl-send-string (format "%s" `(swank:inspector-nth-part ,number)))
+ (slime-repl))
+
+(defun slime-inspector-pop ()
+ (interactive)
+ (slime-eval-async
+ `(swank:inspector-pop)
+ (lambda (result)
+ (cond (result
+ (slime-open-inspector result (pop slime-inspector-mark-stack)))
+ (t
+ (message "No previous object")
+ (ding))))))
+
+(defun slime-inspector-next ()
+ (interactive)
+ (let ((result (slime-eval `(swank:inspector-next))))
+ (cond (result
+ (push (slime-inspector-position) slime-inspector-mark-stack)
+ (slime-open-inspector result))
+ (t (message "No next object")
+ (ding)))))
+
+(defun slime-inspector-quit ()
+ (interactive)
+ (slime-eval-async `(swank:quit-inspector))
+ (set-window-configuration slime-saved-window-config)
+ (kill-buffer (current-buffer)))
+
+(defun slime-find-inspectable-object (direction limit)
+ "Finds the next or previous inspectable object within the
+current buffer, depending on whether DIRECTION is 'NEXT or
+'PREV. LIMIT is the maximum or minimum position in the current
+buffer.
+
+Returns a list of two values: If an object could be found, the
+starting position of the found object and T is returned;
+otherwise LIMIT and NIL is returned.
+"
+ (let ((finder (ecase direction
+ (next 'next-single-property-change)
+ (prev 'previous-single-property-change))))
+ (let ((prop nil) (curpos (point)))
+ (while (and (not prop) (not (= curpos limit)))
+ (let ((newpos (funcall finder curpos 'slime-part-number nil limit)))
+ (setq prop (get-text-property newpos 'slime-part-number))
+ (setq curpos newpos)))
+ (list curpos (and prop t)))))
+
+(defun slime-inspector-next-inspectable-object (arg)
+ "Move point to the next inspectable object.
+With optional ARG, move across that many objects.
+If ARG is negative, move backwards."
+ (interactive "p")
+ (let ((maxpos (point-max)) (minpos (point-min))
+ (previously-wrapped-p nil))
+ ;; Forward.
+ (while (> arg 0)
+ (destructuring-bind (pos foundp)
+ (slime-find-inspectable-object 'next maxpos)
+ (if foundp
+ (progn (goto-char pos) (setq arg (1- arg))
+ (setq previously-wrapped-p nil))
+ (if (not previously-wrapped-p) ; cycle detection
+ (progn (goto-char minpos) (setq previously-wrapped-p t))
+ (error "No inspectable objects")))))
+ ;; Backward.
+ (while (< arg 0)
+ (destructuring-bind (pos foundp)
+ (slime-find-inspectable-object 'prev minpos)
+ ;; SLIME-OPEN-INSPECTOR inserts the title of an inspector page
+ ;; as a presentation at the beginning of the buffer; skip
+ ;; that. (Notice how this problem can not arise in ``Forward.'')
+ (if (and foundp (/= pos minpos))
+ (progn (goto-char pos) (setq arg (1+ arg))
+ (setq previously-wrapped-p nil))
+ (if (not previously-wrapped-p) ; cycle detection
+ (progn (goto-char maxpos) (setq previously-wrapped-p t))
+ (error "No inspectable objects")))))))
+
+
+(defun slime-inspector-previous-inspectable-object (arg)
+ "Move point to the previous inspectable object.
+With optional ARG, move across that many objects.
+If ARG is negative, move forwards."
+ (interactive "p")
+ (slime-inspector-next-inspectable-object (- arg)))
+
+(defun slime-inspector-describe ()
+ (interactive)
+ (slime-eval-describe `(swank:describe-inspectee)))
+
+(defun slime-inspector-pprint (part)
+ (interactive (list (or (get-text-property (point) 'slime-part-number)
+ (error "No part at point"))))
+ (slime-eval-describe `(swank:pprint-inspector-part ,part)))
+
+(defun slime-inspector-reinspect ()
+ (interactive)
+ (slime-eval-async `(swank:inspector-reinspect)
+ (lexical-let ((point (slime-inspector-position)))
+ (lambda (parts)
+ (slime-open-inspector parts point)))))
+
+(slime-define-keys slime-inspector-mode-map
+ ([return] 'slime-inspector-operate-on-point)
+ ((kbd "M-RET") 'slime-inspector-copy-down)
+ ("\C-m" 'slime-inspector-operate-on-point)
+ ([mouse-2] 'slime-inspector-operate-on-click)
+ ("l" 'slime-inspector-pop)
+ ("n" 'slime-inspector-next)
+ (" " 'slime-inspector-next)
+ ("d" 'slime-inspector-describe)
+ ("p" 'slime-inspector-pprint)
+ ("q" 'slime-inspector-quit)
+ ("g" 'slime-inspector-reinspect)
+ ("\C-i" 'slime-inspector-next-inspectable-object)
+ ([(shift tab)] 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB
+ ([backtab] 'slime-inspector-previous-inspectable-object) ; to BACKTAB on X.
+ ("\M-." 'slime-edit-definition))
+
+
+;;;; Buffer selector
+
+(defvar slime-selector-methods nil
+ "List of buffer-selection methods for the `slime-select' command.
+Each element is a list (KEY DESCRIPTION FUNCTION).
+DESCRIPTION is a one-line description of what the key selects.")
+
+(defun slime-selector ()
+ "Select a new buffer by type, indicated by a single character.
+The user is prompted for a single character indicating the method by
+which to choose a new buffer. The `?' character describes the
+available methods.
+
+See `def-slime-selector-method' for defining new methods."
+ (interactive)
+ (message "Select [%s]: "
+ (apply #'string (mapcar #'car slime-selector-methods)))
+ (let* ((ch (save-window-excursion
+ (select-window (minibuffer-window))
+ (read-char)))
+ (method (find ch slime-selector-methods :key #'car)))
+ (cond ((null method)
+ (message "No method for character: ?\\%c" ch)
+ (ding)
+ (sleep-for 1)
+ (discard-input)
+ (slime-selector))
+ (t
+ (funcall (third method))))))
+
+(defmacro def-slime-selector-method (key description &rest body)
+ "Define a new `slime-select' buffer selection method.
+
+KEY is the key the user will enter to choose this method.
+
+DESCRIPTION is a one-line sentence describing how the method
+selects a buffer.
+
+BODY is a series of forms which are evaluated when the selector
+is chosen. The returned buffer is selected with
+switch-to-buffer."
+ `(setq slime-selector-methods
+ (sort* (cons (list ,key ,description
+ (lambda ()
+ (let ((buffer (progn ,@body)))
+ (cond ((get-buffer buffer)
+ (switch-to-buffer buffer))
+ (t
+ (message "No such buffer: %S" buffer)
+ (ding))))))
+ (remove* ,key slime-selector-methods :key #'car))
+ #'< :key #'car)))
+
+(def-slime-selector-method ?? "Selector help buffer."
+ (ignore-errors (kill-buffer "*Select Help*"))
+ (with-current-buffer (get-buffer-create "*Select Help*")
+ (insert "Select Methods:\n\n")
+ (loop for (key line function) in slime-selector-methods
+ do (insert (format "%c:\t%s\n" key line)))
+ (help-mode)
+ (display-buffer (current-buffer) t)
+ (shrink-window-if-larger-than-buffer
+ (get-buffer-window (current-buffer))))
+ (slime-selector)
+ (current-buffer))
+
+(def-slime-selector-method ?r
+ "SLIME Read-Eval-Print-Loop."
+ (cond ((slime-current-connection)
+ (slime-output-buffer))
+ ((y-or-n-p "No connection: start Slime? ")
+ (slime))))
+
+(def-slime-selector-method ?i
+ "*inferior-lisp* buffer."
+ (cond ((and (slime-connected-p) (slime-process))
+ (process-buffer (slime-process)))
+ (t
+ "*inferior-lisp*")))
+
+(def-slime-selector-method ?v
+ "*slime-events* buffer."
+ slime-event-buffer-name)
+
+(def-slime-selector-method ?l
+ "most recently visited lisp-mode buffer."
+ (slime-recently-visited-buffer 'lisp-mode))
+
+(def-slime-selector-method ?d
+ "*sldb* buffer for the current connection."
+ (or (sldb-get-default-buffer)
+ (error "No debugger buffer")))
+
+(def-slime-selector-method ?e
+ "most recently visited emacs-lisp-mode buffer."
+ (slime-recently-visited-buffer 'emacs-lisp-mode))
+
+(def-slime-selector-method ?c
+ "SLIME connections buffer."
+ (slime-list-connections)
+ "*SLIME connections*")
+
+(def-slime-selector-method ?t
+ "SLIME threads buffer."
+ (slime-list-threads)
+ "*slime-threads*")
+
+(defun slime-recently-visited-buffer (mode)
+ "Return the most recently visited buffer whose major-mode is MODE.
+Only considers buffers that are not already visible."
+ (loop for buffer in (buffer-list)
+ when (and (with-current-buffer buffer (eq major-mode mode))
+ (not (string-match "^ " (buffer-name buffer)))
+ (null (get-buffer-window buffer 'visible)))
+ return buffer
+ finally (error "Can't find unshown buffer in %S" mode)))
+
+
+;;;; Editing commands
+
+
+
+;;;; Font Lock
+
+(defcustom slime-highlight-suppressed-forms t
+ "Display forms disabled by reader conditionals as comments."
+ :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+ :group 'slime-mode)
+
+(defface slime-reader-conditional-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit font-lock-comment-face)))
+ '((((background light)) (:foreground "DimGray" :bold t))
+ (((background dark)) (:foreground "LightGray" :bold t))))
+ "Face for compiler notes while selected."
+ :group 'slime-mode-faces)
+
+(defun slime-search-suppressed-forms (limit)
+ "Find reader conditionalized forms where the test is false."
+ (when (and slime-highlight-suppressed-forms
+ (slime-connected-p)
+ (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t))
+ (ignore-errors
+ (let* ((start (- (point) 2))
+ (char (char-before))
+ (e (read (current-buffer)))
+ (val (slime-eval-feature-conditional e)))
+ (when (<= (point) limit)
+ (if (or (and (eq char ?+) (not val))
+ (and (eq char ?-) val))
+ (progn
+ (forward-sexp) (backward-sexp)
+ (slime-forward-sexp)
+ (assert (<= (point) limit))
+ (let ((md (match-data)))
+ (fill md nil)
+ (setf (first md) start)
+ (setf (second md) (point))
+ (set-match-data md)
+ t))
+ (slime-search-suppressed-forms limit)))))))
+
+(defun slime-activate-font-lock-magic ()
+ (if (featurep 'xemacs)
+ (let ((pattern `((slime-search-suppressed-forms
+ (0 slime-reader-conditional-face t)))))
+ (dolist (sym '(lisp-font-lock-keywords
+ lisp-font-lock-keywords-1
+ lisp-font-lock-keywords-2))
+ (set sym (append (symbol-value sym) pattern))))
+ (font-lock-add-keywords
+ 'lisp-mode
+ `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t)))))
+
+(when slime-highlight-suppressed-forms
+ (slime-activate-font-lock-magic))
+
+
+;;;; Indentation
+
+(defun slime-update-indentation ()
+ "Update indentation for all macros defined in the Lisp system."
+ (interactive)
+ (slime-eval-async '(swank:update-indentation-information)))
+
+(defvar slime-indentation-update-hooks)
+
+(defun slime-handle-indentation-update (alist)
+ "Update Lisp indent information.
+
+ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation
+settings for `common-lisp-indent-function'. The appropriate property
+is setup, unless the user already set one explicitly."
+ (dolist (info alist)
+ (let ((symbol (intern (car info)))
+ (indent (cdr info)))
+ ;; Does the symbol have an indentation value that we set?
+ (when (equal (get symbol 'common-lisp-indent-function)
+ (get symbol 'slime-indent))
+ (put symbol 'slime-indent indent)
+ (put symbol 'common-lisp-indent-function indent))
+ (run-hook-with-args 'slime-indentation-update-hooks symbol indent))))
+
+
+;;;; Contrib modules
+
+(defvar slime-required-modules '())
+
+(defun slime-require (module)
+ (assert (keywordp module))
+ (pushnew module slime-required-modules)
+ (when (slime-connected-p)
+ (slime-load-contribs)))
+
+(defun slime-load-contribs ()
+ (let ((needed (remove-if (lambda (s)
+ (member (subseq (symbol-name s) 1)
+ (mapcar #'downcase (slime-lisp-modules))))
+ slime-required-modules)))
+ (when needed
+ (slime-eval-async `(swank:swank-require ',needed)
+ (lambda (new-modules)
+ (setf (slime-lisp-modules) new-modules))))))
+
+
+;;;;; Pull-down menu
+
+(defvar slime-easy-menu
+ (let ((C '(slime-connected-p)))
+ `("SLIME"
+ [ "Edit Definition..." slime-edit-definition ,C ]
+ [ "Return From Definition" slime-pop-find-definition-stack ,C ]
+ [ "Complete Symbol" slime-complete-symbol ,C ]
+ [ "Show REPL" slime-switch-to-output-buffer ,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 ]
+ [ "Eval Region" slime-eval-region ,C ]
+ [ "Interactive Eval..." slime-interactive-eval ,C ]
+ [ "Edit Lisp Value..." slime-edit-value ,C ]
+ [ "Call Defun" slime-call-defun ,C ])
+ ("Debugging"
+ [ "Macroexpand Once..." slime-macroexpand-1 ,C ]
+ [ "Macroexpand All..." slime-macroexpand-all ,C ]
+ [ "Create Trace Buffer" slime-redirect-trace-output ,C ]
+ [ "Toggle Trace..." slime-toggle-trace-fdefinition ,C ]
+ [ "Untrace All" slime-untrace-all ,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 Region" slime-compile-region ,C ]
+ "--"
+ [ "Next Note" slime-next-note t ]
+ [ "Previous Note" slime-previous-note t ]
+ [ "Remove Notes" slime-remove-notes t ]
+ [ "List Notes" slime-list-compiler-notes ,C ])
+ ("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 ])
+ ("Editing"
+ [ "Check Parens" check-parens t]
+ [ "Update Indentation" slime-update-indentation ,C]
+ [ "Select Buffer" slime-selector t])
+ ("Profiling"
+ [ "Toggle Profiling..." slime-toggle-profile-fdefinition ,C ]
+ [ "Profile Package" slime-profile-package ,C]
+ [ "Unprofile All" slime-unprofile-all ,C ]
+ [ "Show Profiled" slime-profiled-functions ,C ]
+ "--"
+ [ "Report" slime-profile-report ,C ]
+ [ "Reset Counters" slime-profile-reset ,C ])
+ ("Documentation"
+ [ "Describe Symbol..." slime-describe-symbol ,C ]
+ [ "Apropos..." slime-apropos ,C ]
+ [ "Apropos all..." slime-apropos-all ,C ]
+ [ "Apropos Package..." slime-apropos-package ,C ]
+ [ "Hyperspec..." slime-hyperspec-lookup t ])
+ "--"
+ [ "Interrupt Command" slime-interrupt ,C ]
+ [ "Abort Async. Command" slime-quit ,C ]
+ [ "Sync Package & Directory" slime-sync-package-and-default-directory ,C]
+ [ "Set Package in REPL" slime-repl-set-package ,C])))
+
+(defvar slime-repl-easy-menu
+ (let ((C '(slime-connected-p)))
+ `("REPL"
+ [ "Send Input" slime-repl-return ,C ]
+ [ "Close and Send Input " slime-repl-closing-return ,C ]
+ [ "Interrupt Lisp process" slime-interrupt ,C ]
+ "--"
+ [ "Previous Input" slime-repl-previous-input t ]
+ [ "Next Input" slime-repl-next-input t ]
+ [ "Goto Previous Prompt " slime-repl-previous-prompt t ]
+ [ "Goto Next Prompt " slime-repl-next-prompt t ]
+ [ "Clear Last Output" slime-repl-clear-output t ]
+ [ "Clear Buffer " slime-repl-clear-buffer t ]
+ [ "Kill Current Input" slime-repl-kill-input t ])))
+
+(defvar slime-sldb-easy-menu
+ (let ((C '(slime-connected-p)))
+ `("SLDB"
+ [ "Next Frame" sldb-down t ]
+ [ "Previous Frame" sldb-up t ]
+ [ "Toggle Frame Details" sldb-toggle-details t ]
+ [ "Next Frame (Details)" sldb-details-down t ]
+ [ "Previous Frame (Details)" sldb-details-up t ]
+ "--"
+ [ "Eval Expression..." slime-interactive-eval ,C ]
+ [ "Eval in Frame..." sldb-eval-in-frame ,C ]
+ [ "Eval in Frame (pretty print)..." sldb-pprint-eval-in-frame ,C ]
+ [ "Inspect In Frame..." sldb-inspect-in-frame ,C ]
+ [ "Inspect Condition Object" sldb-inspect-condition ,C ]
+ [ "Print Condition to REPL" sldb-print-condition t ]
+ "--"
+ [ "Restart Frame" sldb-restart-frame ,C ]
+ [ "Return from Frame..." sldb-return-from-frame ,C ]
+ ("Invoke Restart"
+ [ "Continue" sldb-continue ,C ]
+ [ "Abort" sldb-abort ,C ]
+ [ "Step" sldb-step ,C ]
+ [ "Step next" sldb-next ,C ]
+ [ "Step out" sldb-out ,C ]
+ )
+ "--"
+ [ "Quit (throw)" sldb-quit ,C ]
+ [ "Break With Default Debugger" sldb-break-with-default-debugger ,C ])))
+
+(easy-menu-define menubar-slime slime-mode-map "SLIME" slime-easy-menu)
+
+(defun slime-add-easy-menu ()
+ (easy-menu-add slime-easy-menu 'slime-mode-map))
+
+(add-hook 'slime-mode-hook 'slime-add-easy-menu)
+
+(defun slime-repl-add-easy-menu ()
+ (easy-menu-define menubar-slime-repl slime-repl-mode-map
+ "REPL" slime-repl-easy-menu)
+ (easy-menu-define menubar-slime slime-repl-mode-map
+ "SLIME" slime-easy-menu)
+ (easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map))
+
+(add-hook 'slime-repl-mode-hook 'slime-repl-add-easy-menu)
+
+(defun slime-sldb-add-easy-menu ()
+ (easy-menu-define menubar-slime-sldb
+ sldb-mode-map "SLDB" slime-sldb-easy-menu)
+ (easy-menu-add slime-sldb-easy-menu 'sldb-mode-map))
+
+(add-hook 'sldb-mode-hook 'slime-sldb-add-easy-menu)
+
+
+;;;; Cheat Sheet
+
+(defvar slime-cheat-sheet-table
+ '((:title "Editing lisp code"
+ :map slime-mode-map
+ :bindings ((slime-eval-defun "Evaluate current top level form")
+ (slime-compile-defun "Compile current top level form")
+ (slime-interactive-eval "Prompt for form and eval it")
+ (slime-compile-and-load-file "Compile and load current file")
+ (slime-sync-package-and-default-directory "Synch default package and directory with current buffer")
+ (slime-next-note "Next compiler note")
+ (slime-previous-note "Previous compiler note")
+ (slime-remove-notes "Remove notes")
+ slime-hyperspec-lookup))
+ (:title "Completion"
+ :map slime-mode-map
+ :bindings (slime-indent-and-complete-symbol
+ slime-fuzzy-complete-symbol))
+ (:title "At the REPL"
+ :map slime-repl-mode-map
+ :bindings (slime-repl-clear-buffer
+ slime-describe-symbol))
+ (:title "Within SLDB buffers"
+ :map sldb-mode-map
+ :bindings ((sldb-default-action "Do 'whatever' with thing at point")
+ (sldb-toggle-details "Toggle frame details visualization")
+ (sldb-quit "Quit to REPL")
+ (sldb-abort "Invoke ABORT restart")
+ (sldb-continue "Invoke CONTINUE restart (if available)")
+ (sldb-show-source "Jump to frame's source code")
+ (sldb-eval-in-frame "Evaluate in frame at point")
+ (sldb-inspect-in-frame "Evaluate in frame at point and inspect result")))
+ (:title "Within the Inspector"
+ :map slime-inspector-mode-map
+ :bindings ((slime-inspector-next-inspectable-object "Jump to next inspectable object")
+ (slime-inspector-operate-on-point "Inspect object or execute action at point")
+ (slime-inspector-reinspect "Reinspect current object")
+ (slime-inspector-pop "Return to previous object")
+ (slime-inspector-copy-down "Send object at point to REPL")
+ (slime-inspector-quit "Quit")))
+ (:title "Finding Definitions"
+ :map slime-mode-map
+ :bindings (slime-edit-definition
+ slime-pop-find-definition-stack))))
+
+(defun slime-cheat-sheet ()
+ (interactive)
+ (switch-to-buffer-other-frame (get-buffer-create "*SLIME Cheat Sheet*"))
+ (setq buffer-read-only nil)
+ (delete-region (point-min) (point-max))
+ (goto-char (point-min))
+ (insert "SLIME: The Superior Lisp Interaction Mode for Emacs (minor-mode).\n\n")
+ (dolist (mode slime-cheat-sheet-table)
+ (let ((title (getf mode :title))
+ (mode-map (getf mode :map))
+ (mode-keys (getf mode :bindings)))
+ (insert title)
+ (insert ":\n")
+ (insert (make-string (1+ (length title)) ?-))
+ (insert "\n")
+ (let ((keys '())
+ (descriptions '()))
+ (dolist (func mode-keys)
+ ;; func is eithor the function name or a list (NAME DESCRIPTION)
+ (push (if (symbolp func)
+ (prin1-to-string func)
+ (second func))
+ descriptions)
+ (let ((all-bindings (where-is-internal (if (symbolp func)
+ func
+ (first func))
+ (symbol-value mode-map)))
+ (key-bindings '()))
+ (dolist (binding all-bindings)
+ (when (and (vectorp binding)
+ (integerp (aref binding 0)))
+ (push binding key-bindings)))
+ (push (mapconcat 'key-description key-bindings " or ") keys)))
+ (loop
+ with key-length = (apply 'max (mapcar 'length keys))
+ with desc-length = (apply 'max (mapcar 'length descriptions))
+ for key in (nreverse keys)
+ for desc in (nreverse descriptions)
+ do (insert desc)
+ do (insert (make-string (- desc-length (length desc)) ? ))
+ do (insert " => ")
+ do (insert (if (string= "" key)
+ "<not on any key>"
+ key))
+ do (insert "\n")
+ finally do (insert "\n")))))
+ (setq buffer-read-only t)
+ (goto-char (point-min)))
+
+
+;;;; Test suite
+
+(defstruct (slime-test (:conc-name slime-test.))
+ name fname args doc inputs fails-for)
+
+(defvar slime-tests '()
+ "Names of test functions.")
+
+(defvar slime-test-debug-on-error nil
+ "*When non-nil debug errors in test cases.")
+
+(defvar slime-total-tests nil
+ "Total number of tests executed during a test run.")
+
+(defvar slime-failed-tests nil
+ "Total number of failed tests during a test run.")
+
+(defvar slime-expected-failures nil
+ "Total number of expected failures during a test run")
+
+(defvar slime-test-buffer-name "*Tests*"
+ "The name of the buffer used to display test results.")
+
+
+;; dynamically bound during a single test
+(defvar slime-current-test)
+(defvar slime-unexpected-failures)
+
+
+;;;;; Execution engine
+
+(defun slime-run-tests ()
+ "Run the test suite.
+The results are presented in an outline-mode buffer, with the tests
+that succeeded initially folded away."
+ (interactive)
+ (assert (not (slime-busy-p)))
+ (slime-create-test-results-buffer)
+ (unwind-protect
+ (slime-execute-tests)
+ (pop-to-buffer slime-test-buffer-name)
+ (goto-char (point-min))
+ (hide-body)
+ ;; Expose failed tests
+ (dolist (o (overlays-in (point-min) (point-max)))
+ (when (overlay-get o 'slime-failed-test)
+ (goto-char (overlay-start o))
+ (show-subtree)))))
+
+(defun slime-run-one-test (name)
+ "Ask for the name of a test and then execute the test."
+ (interactive (list (slime-read-test-name)))
+ (let ((test (find name slime-tests :key #'slime-test.name)))
+ (assert test)
+ (let ((slime-tests (list test)))
+ (slime-run-tests))))
+
+(defun slime-read-test-name ()
+ (let ((alist (mapcar (lambda (test)
+ (list (symbol-name (slime-test.name test))))
+ slime-tests)))
+ (read (completing-read "Test: " alist nil t))))
+
+(defun slime-test-should-fail-p (test)
+ (member (slime-lisp-implementation-name)
+ (slime-test.fails-for test)))
+
+(defun slime-execute-tests ()
+ "Execute each test case with each input.
+Return the number of failed tests."
+ (save-window-excursion
+ (let ((slime-total-tests 0)
+ (slime-expected-passes 0)
+ (slime-unexpected-failures 0)
+ (slime-expected-failures 0))
+ (dolist (slime-current-test slime-tests)
+ (with-struct (slime-test. name (function fname) inputs)
+ slime-current-test
+ (slime-test-heading 1 "%s" name)
+ (dolist (input inputs)
+ (incf slime-total-tests)
+ (message "%s: %s" name input)
+ (slime-test-heading 2 "input: %s" input)
+ (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
+ (cond ((slime-test-should-fail-p slime-current-test)
+ (incf slime-expected-failures)
+ (slime-test-failure "ERROR (expected)"
+ (format "%S" err)))
+ (t
+ (incf slime-unexpected-failures)
+ (slime-print-check-error err)))))))))
+ (let ((summary (cond ((and (zerop slime-expected-failures)
+ (zerop slime-unexpected-failures))
+ (format "All %S tests completed successfully."
+ slime-total-tests))
+ (t
+ (format "Failed on %S (%S expected) of %S tests."
+ (+ slime-expected-failures
+ slime-unexpected-failures)
+ slime-expected-failures
+ slime-total-tests)))))
+ (save-excursion
+ (with-current-buffer slime-test-buffer-name
+ (goto-char (point-min))
+ (insert summary "\n\n")))
+ (message "%s" summary)
+ slime-unexpected-failures))))
+
+(defun slime-batch-test (results-file)
+ "Run the test suite in batch-mode.
+Exits Emacs when finished. The exit code is the number of failed tests."
+ (let ((slime-test-debug-on-error nil))
+ (slime)
+ ;; Block until we are up and running.
+ (while (not (slime-connected-p))
+ (sit-for 1))
+ (slime-sync-to-top-level 5)
+ (switch-to-buffer "*scratch*")
+ (let ((failed-tests (slime-run-tests)))
+ (with-current-buffer slime-test-buffer-name
+ (slime-delete-hidden-outline-text)
+ (goto-char (point-min))
+ (insert "-*- outline -*-\n\n")
+ (write-file results-file))
+ (kill-emacs failed-tests))))
+
+
+;;;;; Results buffer creation and output
+
+(defun slime-create-test-results-buffer ()
+ "Create and initialize the buffer for test suite results."
+ (ignore-errors (kill-buffer slime-test-buffer-name))
+ (with-current-buffer (get-buffer-create slime-test-buffer-name)
+ (erase-buffer)
+ (outline-mode)
+ (set (make-local-variable 'outline-regexp) "\\*+")
+ (slime-set-truncate-lines)))
+
+(defun slime-delete-hidden-outline-text ()
+ "Delete the hidden parts of an outline-mode buffer."
+ (loop do (when (eq (get-char-property (point) 'invisible) 'outline)
+ (delete-region (point)
+ (next-single-char-property-change (point)
+ 'invisible)))
+ until (eobp)
+ do (goto-char (next-single-char-property-change (point) 'invisible))))
+
+(defun slime-test-heading (level format &rest args)
+ "Output a test suite heading.
+LEVEL gives the depth of nesting: 1 for top-level, 2 for a subheading, etc."
+ (with-current-buffer slime-test-buffer-name
+ (goto-char (point-max))
+ (insert (make-string level ?*)
+ " "
+ (apply 'format format args)
+ "\n")))
+
+(defun slime-test-failure (keyword string)
+ "Output a failure message from the test suite.
+KEYWORD names the type of failure and STRING describes the reason."
+ (with-current-buffer slime-test-buffer-name
+ (goto-char (point-max))
+ (let ((start (point)))
+ (insert keyword ": ")
+ (let ((overlay (make-overlay start (point))))
+ (overlay-put overlay 'slime-failed-test t)
+ (overlay-put overlay 'face 'bold)))
+ (insert string "\n")))
+
+(defun slime-test-message (string)
+ "Output a message from the test suite."
+ (with-current-buffer slime-test-buffer-name
+ (goto-char (point-max))
+ (insert string "\n")))
+
+
+;;;;; Macros for defining test cases
+
+(defmacro def-slime-test (name args doc inputs &rest body)
+ "Define a test case.
+NAME ::= SYMBOL | (SYMBOL (FAILS-FOR*)) is a symbol naming the test.
+ARGS is a lambda-list.
+DOC is a docstring.
+INPUTS is a list of argument lists, each tested separately.
+BODY is the test case. The body can use `slime-check' to test
+conditions (assertions)."
+ (multiple-value-bind (name fails-for) (etypecase name
+ (symbol (values name '()))
+ (cons name))
+ (let ((fname (intern (format "slime-test-%s" name))))
+ `(progn
+ (defun ,fname ,args
+ ,doc
+ (slime-sync)
+ ,@body)
+ (setq slime-tests
+ (append (remove* ',name slime-tests :key 'slime-test.name)
+ (list (make-slime-test :name ',name :fname ',fname
+ :fails-for ',fails-for
+ :inputs ,inputs))))))))
+
+(defmacro slime-check (test-name &rest body)
+ "Check a condition (assertion.)
+TEST-NAME can be a symbol, a string, or a (FORMAT-STRING . ARGS) list.
+BODY returns true if the check succeeds."
+ (let ((check-name (gensym "check-name-")))
+ `(let ((,check-name ,(typecase test-name
+ (symbol (symbol-name test-name))
+ (string test-name)
+ (cons `(format ,@test-name)))))
+ (if (progn ,@body)
+ (slime-print-check-ok ,check-name)
+ (cond ((slime-test-should-fail-p slime-current-test)
+ (incf slime-expected-failures)
+ (slime-test-failure "FAIL (expected)" ,check-name))
+ (t
+ (incf slime-unexpected-failures)
+ (slime-print-check-failed ,check-name)))
+ (when slime-test-debug-on-error
+ (debug (format "Check failed: %S" ,check-name)))))))
+
+(defun slime-print-check-ok (test-name)
+ (slime-test-message test-name))
+
+(defun slime-print-check-failed (test-name)
+ (slime-test-failure "FAILED" test-name))
+
+(defun slime-print-check-error (reason)
+ (slime-test-failure "ERROR" (format "%S" reason)))
+
+(put 'def-slime-test 'lisp-indent-function 4)
+(put 'slime-check 'lisp-indent-function 1)
+
+
+;;;;; Test case definitions
+
+;; Clear out old tests.
+(setq slime-tests nil)
+
+(defun slime-check-top-level (&optional test-name)
+ (slime-accept-process-output nil 0.001)
+ (slime-check "At the top level (no debugging or pending RPCs)"
+ (slime-at-top-level-p)))
+
+(defun slime-at-top-level-p ()
+ (and (not (sldb-get-default-buffer))
+ (null (slime-rex-continuations))))
+
+(defun slime-wait-condition (name predicate timeout)
+ (let ((end (time-add (current-time) (seconds-to-time timeout))))
+ (while (not (funcall predicate))
+ (cond ((time-less-p end (current-time))
+ (error "Timeout waiting for condition: %S" name))
+ (t
+ ;; XXX if a process-filter enters a recursive-edit, we
+ ;; hang forever
+ (save-excursion
+ (slime-accept-process-output nil 0.1)))))))
+
+(defun slime-sync-to-top-level (timeout)
+ (slime-wait-condition "top-level" #'slime-at-top-level-p timeout))
+
+;; XXX: unused function
+(defun slime-check-sldb-level (expected)
+ (let ((sldb-level (when-let (sldb (sldb-get-default-buffer))
+ (with-current-buffer sldb
+ sldb-level))))
+ (slime-check ("SLDB level (%S) is %S" expected sldb-level)
+ (equal expected sldb-level))))
+
+(defun slime-test-expect (name expected actual &optional test)
+ (when (stringp expected) (setq expected (substring-no-properties expected)))
+ (when (stringp actual) (setq actual (substring-no-properties actual)))
+ (slime-check ("%s:\nexpected: [%S]\n actual: [%S]" name expected actual)
+ (funcall (or test #'equal) expected actual)))
+
+(defun sldb-level ()
+ (when-let (sldb (sldb-get-default-buffer))
+ (with-current-buffer sldb
+ sldb-level)))
+
+(defun slime-sldb-level= (level)
+ (when-let (sldb (sldb-get-default-buffer))
+ (with-current-buffer sldb
+ (equal sldb-level level))))
+
+(def-slime-test narrowing
+ ()
+ "Check that narrowing is properly sustained."
+ '(())
+ (slime-check-top-level)
+ (let ((random-buffer-name (symbol-name (gensym)))
+ (defun-pos) (tmpbuffer))
+ (with-temp-buffer
+ (dotimes (i 100) (insert (format ";;; %d. line\n" i)))
+ (setq tmpbuffer (current-buffer))
+ (setq defun-pos (point))
+ (insert (concat "(defun __foo__ (x y)" "\n"
+ " 'nothing)" "\n"))
+ (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i))))
+ (slime-check "Checking that newly created buffer is not narrowed."
+ (not (slime-buffer-narrowed-p)))
+
+ (goto-char defun-pos)
+ (narrow-to-defun)
+ (slime-check "Checking that narrowing succeeded."
+ (slime-buffer-narrowed-p))
+
+ (slime-with-output-to-temp-buffer (random-buffer-name) nil
+ (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name)
+ (equal (buffer-name (current-buffer)) random-buffer-name))
+ (slime-temp-buffer-quit))
+ (kill-buffer random-buffer-name)
+ (slime-check ("Checking that we've got back from `%s'" random-buffer-name)
+ (and (eq (current-buffer) tmpbuffer)
+ (= (point) defun-pos)))
+
+ (slime-check "Checking that narrowing sustained after quitting Slime's temp buffer."
+ (slime-buffer-narrowed-p))
+
+ (let ((slime-buffer-package "SWANK")
+ (symbol '*buffer-package*))
+ (slime-edit-definition (symbol-name symbol))
+ (slime-check ("Checking that we've got M-. into swank.lisp." symbol)
+ (string= (file-name-nondirectory (buffer-file-name))
+ "swank.lisp"))
+ (slime-pop-find-definition-stack)
+ (slime-check ("Checking that we've got back.")
+ (and (eq (current-buffer) tmpbuffer)
+ (= (point) defun-pos)))
+
+ (slime-check "Checking that narrowing sustained after M-,"
+ (slime-buffer-narrowed-p)))
+ ))
+ (slime-check-top-level))
+
+
+(def-slime-test find-definition
+ (name buffer-package snippet)
+ "Find the definition of a function or macro in swank.lisp."
+ '(("read-from-emacs" "SWANK" "(defun read-from-emacs ")
+ ("swank::read-from-emacs" "CL-USER" "(defun read-from-emacs ")
+ ("swank:start-server" "CL-USER" "(defun start-server "))
+ (switch-to-buffer "*scratch*") ; not buffer of definition
+ (slime-check-top-level)
+ (let ((orig-buffer (current-buffer))
+ (orig-pos (point))
+ (enable-local-variables nil) ; don't get stuck on -*- eval: -*-
+ (slime-buffer-package buffer-package))
+ (slime-edit-definition name)
+ ;; Postconditions
+ (slime-check ("Definition of `%S' is in swank.lisp." name)
+ (string= (file-name-nondirectory (buffer-file-name)) "swank.lisp"))
+ (slime-check "Definition now at point." (looking-at snippet))
+ (slime-pop-find-definition-stack)
+ (slime-check "Returning from definition restores original buffer/position."
+ (and (eq orig-buffer (current-buffer))
+ (= orig-pos (point)))))
+ (slime-check-top-level))
+
+(def-slime-test complete-symbol
+ (prefix expected-completions)
+ "Find the completions of a symbol-name prefix."
+ '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname"
+ "cl:compiled-function" "cl:compiled-function-p" "cl:compiler-macro"
+ "cl:compiler-macro-function")
+ "cl:compile"))
+ ("cl:foobar" (nil ""))
+ ("swank::compile-file" (("swank::compile-file"
+ "swank::compile-file-for-emacs"
+ "swank::compile-file-if-needed"
+ "swank::compile-file-pathname")
+ "swank::compile-file"))
+ ("cl:m-v-l" (nil "")))
+ (let ((completions (slime-simple-completions prefix)))
+ (slime-test-expect "Completion set" expected-completions completions)))
+
+(def-slime-test arglist
+ ;; N.B. Allegro apparently doesn't return the default values of
+ ;; optional parameters. Thus the regexp in the start-server
+ ;; expected value. In a perfect world we'd find a way to smooth
+ ;; over this difference between implementations--perhaps by
+ ;; convincing Franz to provide a function that does what we want.
+ (function-name expected-arglist)
+ "Lookup the argument list for FUNCTION-NAME.
+Confirm that EXPECTED-ARGLIST is displayed."
+ '(("swank::operator-arglist" "(swank::operator-arglist name package)")
+ ("swank::create-socket" "(swank::create-socket host port)")
+ ("swank::emacs-connected" "(swank::emacs-connected )")
+ ("swank::compile-string-for-emacs"
+ "(swank::compile-string-for-emacs string buffer position directory)")
+ ("swank::connection.socket-io"
+ "(swank::connection.socket-io \\(struct\\(ure\\)?\\|object\\|instance\\))")
+ ("cl:lisp-implementation-type" "(cl:lisp-implementation-type )")
+ ("cl:class-name"
+ "(cl:class-name \\(class\\|object\\|instance\\|structure\\))"))
+ (slime-check-top-level)
+ (let ((arglist (slime-eval `(swank:operator-arglist ,function-name
+ "swank"))))
+ (slime-test-expect "Argument list is as expected"
+ expected-arglist (downcase arglist)
+ #'string-match))
+ (slime-check-top-level))
+
+(def-slime-test (compile-defun ("allegro" "lispworks" "clisp"))
+ (program subform)
+ "Compile PROGRAM containing errors.
+Confirm that SUBFORM is correctly located."
+ '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar))
+ ("(defun cl-user::foo ()
+ #\\space
+ ;;Sdf
+ (cl-user::bar))"
+ (cl-user::bar))
+ ("(defun cl-user::foo ()
+ #+(or)skipped
+ #| #||#
+ #||# |#
+ (cl-user::bar))"
+ (cl-user::bar))
+ ("(defun cl-user::foo ()
+ (list `(1 ,(random 10) 2 ,@(random 10) 3 ,(cl-user::bar))))"
+ (cl-user::bar))
+ ("(defun cl-user::foo ()
+ \"\\\" bla bla \\\"\"
+ (cl-user::bar))"
+ (cl-user::bar))
+ ("(defun cl-user::foo ()
+ #.*log-events*
+ (cl-user::bar))"
+ (cl-user::bar))
+ ("#.'(defun x () (/ 1 0))
+ (defun foo ()
+ (cl-user::bar))
+
+ "
+ (cl-user::bar)))
+ (slime-check-top-level)
+ (with-temp-buffer
+ (lisp-mode)
+ (insert program)
+ (setq slime-buffer-package ":swank")
+ (slime-compile-string (buffer-string) 1)
+ (setq slime-buffer-package ":cl-user")
+ (slime-sync-to-top-level 5)
+ (goto-char (point-max))
+ (slime-previous-note)
+ (slime-check error-location-correct
+ (equal (read (current-buffer))
+ subform)))
+ (slime-check-top-level))
+
+(def-slime-test async-eval-debugging (depth)
+ "Test recursive debugging of asynchronous evaluation requests."
+ '((1) (2) (3))
+ (slime-check-top-level)
+ (lexical-let ((depth depth)
+ (debug-hook-max-depth 0))
+ (let ((debug-hook
+ (lambda ()
+ (with-current-buffer (sldb-get-default-buffer)
+ (when (> sldb-level debug-hook-max-depth)
+ (setq debug-hook-max-depth sldb-level)
+ (if (= sldb-level depth)
+ ;; We're at maximum recursion - time to unwind
+ (sldb-quit)
+ ;; Going down - enter another recursive debug
+ ;; Recursively debug.
+ (slime-eval-async 'no-such-variable)))))))
+ (let ((sldb-hook (cons debug-hook sldb-hook)))
+ (slime-eval-async 'no-such-variable)
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level)
+ (slime-check ("Maximum depth reached (%S) is %S."
+ debug-hook-max-depth depth)
+ (= debug-hook-max-depth depth))))))
+
+(def-slime-test unwind-to-previous-sldb-level (level2 level1)
+ "Test recursive debugging and returning to lower SLDB levels."
+ '((2 1) (4 2))
+ (slime-check-top-level)
+ (lexical-let ((level2 level2)
+ (level1 level1)
+ (state 'enter)
+ (max-depth 0))
+ (let ((debug-hook
+ (lambda ()
+ (with-current-buffer (sldb-get-default-buffer)
+ (setq max-depth (max sldb-level max-depth))
+ (ecase state
+ (enter
+ (cond ((= sldb-level level2)
+ (setq state 'leave)
+ (sldb-invoke-restart (sldb-first-abort-restart)))
+ (t
+ (slime-eval-async `(cl:aref cl:nil ,sldb-level)))))
+ (leave
+ (cond ((= sldb-level level1)
+ (setq state 'ok)
+ (sldb-quit))
+ (t
+ (sldb-invoke-restart (sldb-first-abort-restart))
+ ))))))))
+ (let ((sldb-hook (cons debug-hook sldb-hook)))
+ (slime-eval-async `(cl:aref cl:nil 0))
+ (slime-sync-to-top-level 15)
+ (slime-check-top-level)
+ (slime-check ("Maximum depth reached (%S) is %S." max-depth level2)
+ (= max-depth level2))
+ (slime-check ("Final state reached.")
+ (eq state 'ok))))))
+
+(defun sldb-first-abort-restart ()
+ (let ((case-fold-search t))
+ (position-if (lambda (x) (string-match "abort" (car x))) sldb-restarts)))
+
+(def-slime-test loop-interrupt-quit
+ ()
+ "Test interrupting a loop."
+ '(())
+ (slime-check-top-level)
+ (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER")
+ (slime-accept-process-output nil 1)
+ (slime-check "In eval state." (slime-busy-p))
+ (slime-interrupt)
+ (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-quit))
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level))
+
+(def-slime-test loop-interrupt-continue-interrupt-quit
+ ()
+ "Test interrupting a previously interrupted but continued loop."
+ '(())
+ (slime-check-top-level)
+ (slime-eval-async '(cl:loop) (lambda (_) ) "CL-USER")
+ (sleep-for 1)
+ (slime-wait-condition "running" #'slime-busy-p 5)
+ (slime-interrupt)
+ (slime-wait-condition "First interrupt" (lambda () (slime-sldb-level= 1)) 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-continue))
+ (slime-wait-condition "running" (lambda ()
+ (and (slime-busy-p)
+ (not (sldb-get-default-buffer)))) 5)
+ (slime-interrupt)
+ (slime-wait-condition "Second interrupt" (lambda () (slime-sldb-level= 1)) 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-quit))
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level))
+
+(def-slime-test interactive-eval
+ ()
+ "Test interactive eval and continuing from the debugger."
+ '(())
+ (slime-check-top-level)
+ (lexical-let ((done nil))
+ (let ((sldb-hook (lambda () (sldb-continue) (setq done t))))
+ (slime-interactive-eval
+ "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))")
+ (while (not done) (slime-accept-process-output))
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level)
+ (let ((message (current-message)))
+ (slime-check "Minibuffer contains: \"3\""
+ (equal "=> 3 (#x3, #o3, #b11)" message))))))
+
+(def-slime-test interrupt-bubbling-idiot
+ ()
+ "Test interrupting a loop that sends a lot of output to Emacs."
+ '(())
+ (slime-accept-process-output nil 1)
+ (slime-check-top-level)
+ (slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i)
+ (cl:finish-output)))
+ (lambda (_) )
+ "CL-USER")
+ (sleep-for 1)
+ (slime-interrupt)
+ (slime-wait-condition "Debugger visible"
+ (lambda ()
+ (and (slime-sldb-level= 1)
+ (get-buffer-window (sldb-get-default-buffer))))
+ 30)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-quit))
+ (slime-sync-to-top-level 5))
+
+(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")))
+ (with-current-buffer (slime-output-buffer)
+ (let ((p (slime-eval
+ `(swank:listener-eval
+ ,(format
+ "(cl:setq cl:*print-case* :upcase)
+ (cl:setq cl:*package* (cl:find-package %S))
+ (cl:package-name cl:*package*)" package-name))
+ (slime-lisp-package))))
+ (slime-check ("slime-lisp-package is %S." package-name)
+ (equal (slime-lisp-package) package-name))
+ (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames)
+ (member (slime-lisp-package-prompt-string) nicknames)))))
+
+(def-slime-test repl-test
+ (input result-contents)
+ "Test simple commands in the minibuffer."
+ '(("(+ 1 2)" "SWANK> (+ 1 2)
+3
+SWANK> ")
+ ("(princ 10)" "SWANK> (princ 10)
+10
+10
+SWANK> ")
+ ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
+1020
+20
+SWANK> ")
+ ("(dotimes (i 10 77) (princ i) (terpri))"
+ "SWANK> (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-prompt-string) "SWANK"))
+ (kill-buffer (slime-output-buffer))
+ (with-current-buffer (slime-output-buffer)
+ (insert input)
+ (slime-test-expect "Buffer contains input"
+ (concat "SWANK> " input)
+ (buffer-string))
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ result-contents (buffer-string))))
+
+(def-slime-test repl-return
+ (before after result-contents)
+ "Test if slime-repl-return sends the correct protion to Lisp even
+if point is not at the end of the line."
+ '(("(+ 1 2)" "" "SWANK> (+ 1 2)
+3
+SWANK> ")
+("(+ 1 " "2)" "SWANK> (+ 1 2)
+3
+SWANK> ")
+
+("(+ 1\n" "2)" "SWANK> (+ 1
+2)
+3
+SWANK> "))
+ (with-current-buffer (slime-output-buffer)
+ (setf (slime-lisp-package-prompt-string) "SWANK"))
+ (kill-buffer (slime-output-buffer))
+ (with-current-buffer (slime-output-buffer)
+ (insert before)
+ (save-excursion (insert after))
+ (slime-test-expect "Buffer contains input"
+ (concat "SWANK> " before after)
+ (buffer-string))
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (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" "SWANK> (values (read-line))
+foo
+\"foo\"
+SWANK> ")
+ ("(read-char)" "1" "SWANK> (values (read-char))
+1
+#\\1
+SWANK> ")
+ ("(read)" "(+ 2 3
+4)" "SWANK> (values (read))
+\(+ 2 3
+4)
+\(+ 2 3 4)
+SWANK> "))
+ (slime-sync-to-top-level 2)
+ (with-current-buffer (slime-output-buffer)
+ (setf (slime-lisp-package-prompt-string) "SWANK"))
+ (kill-buffer (slime-output-buffer))
+ (with-current-buffer (slime-output-buffer)
+ (insert (format "(values %s)" prompt))
+ (call-interactively 'slime-repl-return)
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (insert input)
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ result-contents (buffer-string))))
+
+(def-slime-test repl-read-lines
+ (command inputs final-contents)
+ "Test reading multiple lines from the repl."
+ '(("(list (read-line) (read-line) (read-line))"
+ ("a" "b" "c")
+ "SWANK> (list (read-line) (read-line) (read-line))
+a
+b
+c
+\(\"a\" \"b\" \"c\")
+SWANK> "))
+ (when (slime-output-buffer)
+ (kill-buffer (slime-output-buffer)))
+ (with-current-buffer (slime-output-buffer)
+ (setf (slime-lisp-package-prompt-string) "SWANK")
+ (insert command)
+ (call-interactively 'slime-repl-return)
+ (dolist (input inputs)
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (insert input)
+ (call-interactively 'slime-repl-return))
+ (slime-sync-to-top-level 5)
+ (slime-check "Buffer contains result"
+ (equal final-contents (buffer-string)))))
+
+(def-slime-test repl-type-ahead
+ (command input final-contents)
+ "Ensure that user input is preserved correctly.
+In particular, input inserted while waiting for a result."
+ '(("(sleep 1)" "foo" "SWANK> (sleep 1)
+NIL
+SWANK> foo"))
+ (when (slime-output-buffer)
+ (kill-buffer (slime-output-buffer)))
+ (setf (slime-lisp-package-prompt-string) "SWANK")
+ (with-current-buffer (slime-output-buffer)
+ (insert command)
+ (call-interactively 'slime-repl-return)
+ (insert input)
+ (slime-sync-to-top-level 5)
+ (slime-check "Buffer contains result"
+ (equal final-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)
+ ("(princ \"����������������������������\")"
+ ";;;; (princ \"����������������������������\") ...
+����������������������������
+SWANK> " t))
+ (when (and (fboundp 'string-to-multibyte)
+ (with-current-buffer (process-buffer (slime-connection))
+ enable-multibyte-characters))
+ (setq input (funcall 'string-to-multibyte input))
+ (setq result-contents (funcall 'string-to-multibyte result-contents)))
+ (with-current-buffer (slime-output-buffer)
+ (setf (slime-lisp-package-prompt-string) "SWANK"))
+ (kill-buffer (slime-output-buffer))
+ (with-current-buffer (slime-output-buffer)
+ (slime-interactive-eval input)
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ result-contents (buffer-string))
+ (slime-test-expect "Buffer visible?"
+ visiblep
+ (not (not (get-buffer-window (current-buffer)))))))
+
+(def-slime-test break
+ ()
+ "Test if BREAK invokes SLDB."
+ '(())
+ (slime-accept-process-output nil 1)
+ (slime-check-top-level)
+ (slime-compile-string (prin1-to-string '(cl:defun cl-user::foo ()
+ (cl:break)))
+ 0)
+ (slime-sync-to-top-level 2)
+ (slime-eval-async '(cl-user::foo))
+ (slime-wait-condition "Debugger visible"
+ (lambda ()
+ (and (slime-sldb-level= 1)
+ (get-buffer-window (sldb-get-default-buffer))))
+ 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-quit))
+ (slime-accept-process-output nil 1)
+ (slime-sync-to-top-level 5))
+
+(def-slime-test interrupt-at-toplevel
+ ()
+ "Let's see what happens if we send a user interrupt at toplevel."
+ '(())
+ (slime-check-top-level)
+ (slime-interrupt)
+ (slime-wait-condition "Debugger visible"
+ (lambda ()
+ (and (slime-sldb-level= 1)
+ (get-buffer-window (sldb-get-default-buffer))))
+ 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-quit))
+ (slime-sync-to-top-level 5))
+
+(def-slime-test interrupt-in-blocking-read
+ ()
+ "Let's see what happens if we interrupt a blocking read operation."
+ '(())
+ (slime-check-top-level)
+ (when (slime-output-buffer)
+ (setf (slime-lisp-package-prompt-string) "SWANK")
+ (kill-buffer (slime-output-buffer)))
+ (with-current-buffer (slime-output-buffer)
+ (insert "(read-char)")
+ (call-interactively 'slime-repl-return))
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (slime-interrupt)
+ (slime-wait-condition "Debugger visible"
+ (lambda ()
+ (and (slime-sldb-level= 1)
+ (get-buffer-window (sldb-get-default-buffer))))
+ 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-continue))
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (with-current-buffer (slime-output-buffer)
+ (insert "X")
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ "SWANK> (read-char)
+X
+#\\X
+SWANK> " (buffer-string))))
+
+(def-slime-test disconnect
+ ()
+ "Close the connetion.
+Confirm that the subprocess continues gracefully.
+Reconnect afterwards."
+ '(())
+ (slime-check-top-level)
+ (let* ((c (slime-connection))
+ (p (slime-inferior-process c)))
+ (with-current-buffer (process-buffer p)
+ (erase-buffer))
+ (delete-process c)
+ (assert (equal (process-status c) 'closed) nil "Connection not closed")
+ (slime-accept-process-output nil 0.1)
+ (assert (equal (process-status p) 'run) nil "Subprocess not running")
+ (with-current-buffer (process-buffer p)
+ (assert (< (buffer-size) 500) nil "Unusual output"))
+ (slime-inferior-connect p (slime-inferior-lisp-args p))
+ (lexical-let ((hook nil))
+ (setq hook (lambda ()
+ (remove-hook 'slime-connected-hook hook)))
+ (add-hook 'slime-connected-hook hook)
+ (while (member hook slime-connected-hook)
+ (sit-for 0.5)
+ (slime-accept-process-output nil 0.1)))
+ (slime-test-expect "We are connected again" p (slime-inferior-process))))
+
+
+;;;; Utilities
+
+;;;;; Misc.
+
+(defun slime-length= (seq n)
+ "Test for whether SEQ contains N number of elements. I.e. it's equivalent
+ to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
+ efficiently implemented."
+ (etypecase seq
+ (list
+ (let ((list seq))
+ (setq list (nthcdr (1- n) list))
+ (and list (null (cdr list)))))
+ (sequence
+ (= (length seq) n))))
+
+(defun slime-length> (seq n)
+ "Return non-nil if (> (length LIST) N)."
+ (etypecase seq
+ (list (nthcdr n seq))
+ (seq (> (length seq) n))))
+
+;;;;; Buffer related
+
+(defun slime-buffer-narrowed-p (&optional buffer)
+ "Returns T if BUFFER (or the current buffer respectively) is narrowed."
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((beg (point-min))
+ (end (point-max))
+ (total (buffer-size)))
+ (or (/= beg 1) (/= end (1+ total))))))
+
+
+;;;;; Extracting Lisp forms from the buffer or user
+
+(defun slime-defun-at-point ()
+ "Return the text of the defun at point."
+ (apply #'buffer-substring-no-properties
+ (slime-region-for-defun-at-point)))
+
+(defvar slime-region-for-defun-function nil)
+
+(defun slime-region-for-defun-at-point ()
+ "Return the start and end position of the toplevel form at point."
+ (or (and slime-region-for-defun-function
+ (funcall slime-region-for-defun-function))
+ (save-excursion
+ (save-match-data
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-sexp)
+ (list (point) end))))))
+
+(defun slime-beginning-of-symbol ()
+ "Move point to the beginning of the current symbol."
+ (when (slime-point-moves-p
+ (while (slime-point-moves-p
+ (skip-syntax-backward "w_")
+ (when (eq (char-before) ?|)
+ (backward-char)))))
+ (when (eq (char-before) ?#) ; special case for things like "#<foo"
+ (forward-char))))
+
+(defun slime-end-of-symbol ()
+ "Move point to the end of the current symbol."
+ (while (slime-point-moves-p
+ (skip-syntax-forward "w_")
+ ;; | has the syntax as ", so we need to
+ ;; treat it manually rather than via syntax.
+ (when (looking-at "|")
+ (forward-char)))))
+
+(put 'slime-symbol 'end-op 'slime-end-of-symbol)
+(put 'slime-symbol 'beginning-op 'slime-beginning-of-symbol)
+
+(defun slime-symbol-start-pos ()
+ "Return the starting position of the symbol under point.
+The result is unspecified if there isn't a symbol under the point."
+ (save-excursion (slime-beginning-of-symbol) (point)))
+
+(defun slime-symbol-end-pos ()
+ (save-excursion (slime-end-of-symbol) (point)))
+
+(defun slime-symbol-name-at-point ()
+ "Return the name of the symbol at point, otherwise nil."
+ (save-restriction
+ ;; Don't be tricked into grabbing the REPL prompt.
+ (when (and (eq major-mode 'slime-repl-mode)
+ (>= (point) slime-repl-input-start-mark))
+ (narrow-to-region slime-repl-input-start-mark (point-max)))
+ (save-excursion
+ (let ((string (thing-at-point 'slime-symbol)))
+ (and string
+ ;; In Emacs20 (thing-at-point 'symbol) returns "" instead
+ ;; of nil when called from an empty (or
+ ;; narrowed-to-empty) buffer.
+ (not (equal string ""))
+ (substring-no-properties string))))))
+
+(defun slime-symbol-at-point ()
+ "Return the symbol at point, otherwise nil."
+ (let ((name (slime-symbol-name-at-point)))
+ (and name (intern name))))
+
+(defun slime-sexp-at-point ()
+ "Return the sexp at point as a string, otherwise nil."
+ (let ((string (thing-at-point 'sexp)))
+ (if string (substring-no-properties string) nil)))
+
+(defun slime-sexp-at-point-or-error ()
+ "Return the sexp at point as a string, othwise signal an error."
+ (or (slime-sexp-at-point)
+ (error "No expression at point.")))
+
+;;;; Portability library
+
+(when (featurep 'xemacs)
+ (require 'overlay))
+
+(defun slime-split-string (string &optional separators omit-nulls)
+ "This is like `split-string' in Emacs22, but also works in
+Emacs20 and 21."
+ (let ((splits (split-string string separators)))
+ (if omit-nulls
+ (setq splits (remove "" splits))
+ ;; SPLIT-STRING in Emacs before 22.x automatically removed nulls
+ ;; at beginning and end, so we gotta add them here again.
+ (when (or (slime-emacs-20-p) (slime-emacs-21-p))
+ (when (find (elt string 0) separators)
+ (push "" splits))
+ (when (find (elt string (1- (length string))) separators)
+ (setq splits (append splits (list ""))))))
+ splits))
+
+(defun slime-delete-and-extract-region (start end)
+ "Like `delete-and-extract-region' except that it is guaranteed
+to return a string. At least Emacs 21.3.50 returned `nil' on
+\(delete-and-extract-region (point) (point)), this function
+will return \"\"."
+ (let ((result (delete-and-extract-region start end)))
+ (if (null result)
+ ""
+ (assert (stringp result))
+ result)))
+
+(defmacro slime-defun-if-undefined (name &rest rest)
+ ;; We can't decide at compile time whether NAME is properly
+ ;; bound. So we delay the decision to runtime to ensure some
+ ;; definition
+ `(unless (fboundp ',name)
+ (defun ,name ,@rest)))
+
+(put 'slime-defun-if-undefined 'lisp-indent-function 2)
+
+(defvar slime-accept-process-output-supports-floats
+ (ignore-errors (accept-process-output nil 0.0) t))
+
+(defun slime-accept-process-output (&optional process timeout)
+ "Like `accept-process-output' but the TIMEOUT argument can be a float."
+ (cond (slime-accept-process-output-supports-floats
+ (accept-process-output process timeout))
+ (t
+ (accept-process-output process
+ (if timeout (truncate timeout))
+ ;; Emacs 21 uses microsecs; Emacs 22 millisecs
+ (if timeout (truncate (* timeout 1000000)))))))
+
+(slime-defun-if-undefined next-single-char-property-change
+ (position prop &optional object limit)
+ (let ((limit (typecase limit
+ (null nil)
+ (marker (marker-position limit))
+ (t limit))))
+ (if (stringp object)
+ (or (next-single-property-change position prop object limit)
+ limit
+ (length object))
+ (with-current-buffer (or object (current-buffer))
+ (let ((initial-value (get-char-property position prop object))
+ (limit (or limit (point-max))))
+ (loop for pos = position then (next-char-property-change pos limit)
+ if (>= pos limit) return limit
+ if (not (eq initial-value
+ (get-char-property pos prop object)))
+ return pos))))))
+
+(slime-defun-if-undefined previous-single-char-property-change
+ (position prop &optional object limit)
+ (let ((limit (typecase limit
+ (null nil)
+ (marker (marker-position limit))
+ (t limit))))
+ (if (stringp object)
+ (or (previous-single-property-change position prop object limit)
+ limit
+ (length object))
+ (with-current-buffer (or object (current-buffer))
+ (let ((limit (or limit (point-min))))
+ (if (<= position limit)
+ limit
+ (let ((initial-value (get-char-property (1- position)
+ prop object)))
+ (loop for pos = position then
+ (previous-char-property-change pos limit)
+ if (<= pos limit) return limit
+ if (not (eq initial-value
+ (get-char-property (1- pos) prop object)))
+ return pos))))))))
+
+(slime-defun-if-undefined next-char-property-change (position &optional limit)
+ (let ((tmp (next-overlay-change position)))
+ (when tmp
+ (setq tmp (min tmp limit)))
+ (next-property-change position nil tmp)))
+
+(slime-defun-if-undefined previous-char-property-change
+ (position &optional limit)
+ (let ((tmp (previous-overlay-change position)))
+ (when tmp
+ (setq tmp (max tmp limit)))
+ (previous-property-change position nil tmp)))
+
+(slime-defun-if-undefined substring-no-properties (string &optional start end)
+ (let* ((start (or start 0))
+ (end (or end (length string)))
+ (string (substring string start end)))
+ (set-text-properties 0 (- end start) nil string)
+ string))
+
+(slime-defun-if-undefined match-string-no-properties (num &optional string)
+ (if (match-beginning num)
+ (if string
+ (substring-no-properties string (match-beginning num)
+ (match-end num))
+ (buffer-substring-no-properties (match-beginning num)
+ (match-end num)))))
+
+(slime-defun-if-undefined set-window-text-height (window height)
+ (let ((delta (- height (window-text-height window))))
+ (unless (zerop delta)
+ (let ((window-min-height 1))
+ (if (and window (not (eq window (selected-window))))
+ (save-selected-window
+ (select-window window)
+ (enlarge-window delta))
+ (enlarge-window delta))))))
+
+(slime-defun-if-undefined window-text-height (&optional window)
+ (1- (window-height window)))
+
+(slime-defun-if-undefined subst-char-in-string (fromchar tochar string
+ &optional inplace)
+ "Replace FROMCHAR with TOCHAR in STRING each time it occurs.
+Unless optional argument INPLACE is non-nil, return a new string."
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr))
+
+(slime-defun-if-undefined count-screen-lines
+ (&optional beg end count-final-newline window)
+ (unless beg
+ (setq beg (point-min)))
+ (unless end
+ (setq end (point-max)))
+ (if (= beg end)
+ 0
+ (save-excursion
+ (save-restriction
+ (widen)
+ (narrow-to-region (min beg end)
+ (if (and (not count-final-newline)
+ (= ?\n (char-before (max beg end))))
+ (1- (max beg end))
+ (max beg end)))
+ (goto-char (point-min))
+ ;; XXX make this xemacs compatible
+ (1+ (vertical-motion (buffer-size) window))))))
+
+(slime-defun-if-undefined seconds-to-time (seconds)
+ "Convert SECONDS (a floating point number) to a time value."
+ (list (floor seconds 65536)
+ (floor (mod seconds 65536))
+ (floor (* (- seconds (ffloor seconds)) 1000000))))
+
+(slime-defun-if-undefined time-less-p (t1 t2)
+ "Say whether time value T1 is less than time value T2."
+ (or (< (car t1) (car t2))
+ (and (= (car t1) (car t2))
+ (< (nth 1 t1) (nth 1 t2)))))
+
+(slime-defun-if-undefined time-add (t1 t2)
+ "Add two time values. One should represent a time difference."
+ (let ((high (car t1))
+ (low (if (consp (cdr t1)) (nth 1 t1) (cdr t1)))
+ (micro (if (numberp (car-safe (cdr-safe (cdr t1))))
+ (nth 2 t1)
+ 0))
+ (high2 (car t2))
+ (low2 (if (consp (cdr t2)) (nth 1 t2) (cdr t2)))
+ (micro2 (if (numberp (car-safe (cdr-safe (cdr t2))))
+ (nth 2 t2)
+ 0)))
+ ;; Add
+ (setq micro (+ micro micro2))
+ (setq low (+ low low2))
+ (setq high (+ high high2))
+
+ ;; Normalize
+ ;; `/' rounds towards zero while `mod' returns a positive number,
+ ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))).
+ (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0)))
+ (setq micro (mod micro 1000000))
+ (setq high (+ high (/ low 65536) (if (< low 0) -1 0)))
+ (setq low (logand low 65535))
+
+ (list high low micro)))
+
+(slime-defun-if-undefined line-beginning-position (&optional n)
+ (save-excursion
+ (beginning-of-line n)
+ (point)))
+
+(slime-defun-if-undefined line-end-position (&optional n)
+ (save-excursion
+ (end-of-line n)
+ (point)))
+
+(slime-defun-if-undefined check-parens ()
+ "Verify that parentheses in the current buffer are balanced.
+If they are not, position point at the first syntax error found."
+ (interactive)
+ (let ((saved-point (point))
+ (state (parse-partial-sexp (point-min) (point-max) -1)))
+ (destructuring-bind (depth innermost-start last-terminated-start
+ in-string in-comment after-quote
+ minimum-depth comment-style
+ comment-or-string-start &rest _) state
+ (cond ((and (zerop depth)
+ (not in-string)
+ (or (not in-comment)
+ (and (eq comment-style nil)
+ (eobp)))
+ (not after-quote))
+ (goto-char saved-point)
+ (message "All parentheses appear to be balanced."))
+ ((plusp depth)
+ (goto-char innermost-start)
+ (error "Missing )"))
+ ((minusp depth)
+ (error "Extra )"))
+ (in-string
+ (goto-char comment-or-string-start)
+ (error "String not terminated"))
+ (in-comment
+ (goto-char comment-or-string-start)
+ (error "Comment not terminated"))
+ (after-quote
+ (error "After quote"))
+ (t (error "Shouldn't happen: parsing state: %S" state))))))
+
+(slime-defun-if-undefined read-directory-name (prompt
+ &optional dir default-dirname
+ mustmatch initial)
+ (unless dir
+ (setq dir default-directory))
+ (unless default-dirname
+ (setq default-dirname
+ (if initial (concat dir initial) default-directory)))
+ (let ((file (read-file-name prompt dir default-dirname mustmatch initial)))
+ (setq file (file-name-as-directory (expand-file-name file)))
+ (cond ((file-directory-p file)
+ file)
+ (t
+ (error "Not a directory: %s" file)))))
+
+(slime-defun-if-undefined check-coding-system (coding-system)
+ (or (eq coding-system 'binary)
+ (error "No such coding system: %S" coding-system)))
+
+(slime-defun-if-undefined process-coding-system (process)
+ '(binary . binary))
+
+(slime-defun-if-undefined set-process-coding-system
+ (process &optional decoding encoding))
+
+(unless (boundp 'temporary-file-directory)
+ (defvar temporary-file-directory
+ (file-name-as-directory
+ (cond ((memq system-type '(ms-dos windows-nt))
+ (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
+ ((memq system-type '(vax-vms axp-vms))
+ (or (getenv "TMPDIR") (getenv "TMP")
+ (getenv "TEMP") "SYS$SCRATCH:"))
+ (t
+ (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
+ "The directory for writing temporary files."))
+
+(unless (fboundp 'with-temp-message)
+ (defmacro with-temp-message (message &rest body)
+ (let ((current-message (make-symbol "current-message"))
+ (temp-message (make-symbol "with-temp-message")))
+ `(let ((,temp-message ,message)
+ (,current-message))
+ (unwind-protect
+ (progn
+ (when ,temp-message
+ (setq ,current-message (current-message))
+ (message "%s" ,temp-message))
+ ,@body)
+ (and ,temp-message ,current-message
+ (message "%s" ,current-message)))))))
+
+(defun slime-emacs-20-p ()
+ (and (not (featurep 'xemacs))
+ (= emacs-major-version 20)))
+
+(defun slime-emacs-21-p ()
+ (and (not (featurep 'xemacs))
+ (= emacs-major-version 21)))
+
+(when (featurep 'xemacs)
+ (add-hook 'sldb-hook 'sldb-xemacs-emulate-point-entered-hook))
+
+(defun sldb-xemacs-emulate-point-entered-hook ()
+ (add-hook (make-local-variable 'post-command-hook)
+ 'sldb-xemacs-post-command-hook))
+
+(defun sldb-xemacs-post-command-hook ()
+ (when (get-text-property (point) 'point-entered)
+ (funcall (get-text-property (point) 'point-entered))))
+
+(slime-defun-if-undefined with-selected-window (window &rest body)
+ `(save-selected-window
+ (select-window ,window)
+ ,@body))
+
+;;; Stuff only available in XEmacs
+(slime-defun-if-undefined add-local-hook (hook function &optional append)
+ (make-local-hook hook)
+ (add-hook hook function append t))
+
+(slime-defun-if-undefined remove-local-hook (hook function)
+ (if (local-variable-p hook (current-buffer))
+ (remove-hook hook function t)))
+
+;;;; Some "nice" backward compatiblity bindings for lusers.
+
+(defvar slime-obsolete-commands
+ '(("\C-c\M-i" (slime repl) slime-fuzzy-complete-symbol)
+ ;; Don't shadow bindings in lisp-mode-map
+ ;;("\M-\C-a" (slime) slime-beginning-of-defun)
+ ;;("\M-\C-e" (slime) slime-end-of-defun)
+ ("\C-c\M-q" (slime) slime-reindent-defun)
+ ("\C-c\C-s" (slime) slime-complete-form)
+ ;; (nil nil slime-close-all-parens-in-sexp)
+ ))
+
+(defun slime-bind-obsolete-commands ()
+ (loop for (key maps command) in slime-obsolete-commands do
+ (dolist (m maps) (slime-bind-obsolete-command m key command))))
+
+(defun slime-bind-obsolete-command (map key command)
+ (let ((map (ecase map
+ (slime slime-mode-map)
+ (repl slime-repl-mode-map))))
+ (unless (lookup-key map key)
+ (define-key map key `(lambda (&rest _)
+ (interactive)
+ (slime-upgrade-notice ',command))))))
+
+(slime-bind-obsolete-commands)
+
+(defun slime-upgrade-notice (command)
+ (slime-timebomb (format "The command `%s' has been moved to contrib.
+Please consult the README file in the contrib directory for details.
+
+To fetch the contrib directoy use: cvs update -d"
+ command)
+ 15))
+
+;;;;; ... with gratuitous bloat
+
+(defun slime-timebomb (message timeout)
+ (with-current-buffer (generate-new-buffer "*warning*")
+ (insert message "\n\n")
+ (slime-timebomb-progress (point-marker) timeout)
+ (goto-char (point-min))
+ (pop-to-buffer (current-buffer))))
+
+(defun slime-timebomb-progress (mark timeout)
+ (let ((buffer (marker-buffer mark)))
+ (cond ((not (buffer-live-p buffer)))
+ ((zerop timeout) (kill-buffer buffer))
+ (t (with-current-buffer buffer
+ (save-excursion
+ (delete-region mark (point-max))
+ (goto-char mark)
+ (slime-timebomb-message timeout))
+ (run-with-timer 1 nil
+ 'slime-timebomb-progress mark (1- timeout)))))))
+
+(defun slime-timebomb-message (timeout)
+ (slime-insert-propertized
+ (list 'face (if (zerop (mod timeout 2)) 'highlight 'default))
+ (format "This message will destroy itself in %d seconds." timeout)))
+
+
+;;;; Finishing up
+
+(require 'bytecomp)
+(let ((byte-compile-warnings '()))
+ (mapc #'byte-compile
+ '(slime-alistify
+ slime-log-event
+ slime-events-buffer
+ slime-write-string
+ slime-output-buffer
+ slime-connection-output-buffer
+ slime-output-filter
+ slime-repl-show-maximum-output
+ slime-process-available-input
+ slime-dispatch-event
+ slime-net-filter
+ slime-net-have-input-p
+ slime-net-decode-length
+ slime-net-read
+ slime-print-apropos
+ slime-show-note-counts
+ slime-insert-propertized
+ slime-tree-insert)))
+
+(provide 'slime)
+(run-hooks 'slime-load-hook)
+
+;; Local Variables:
+;; outline-regexp: ";;;;+"
+;; indent-tabs-mode: nil
+;; coding: latin-1-unix!
+;; unibyte: t
+;; compile-command: "emacs -batch -L . -eval '(byte-compile-file \"slime.el\")' ; rm -v slime.elc"
+;; End:
+;;; slime.el ends here
Added: branches/bos/thirdparty/emacs/slime/swank-abcl.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-abcl.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,571 @@
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
+;;;
+;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
+;;;
+;;; Adapted from swank-acl.lisp, Andras Simon, 2004
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package :swank-backend)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :collect) ;just so that it doesn't spoil the flying letters
+ (require :pprint))
+
+(defun sys::break (&optional (format-control "BREAK called")
+ &rest format-arguments)
+ (let ((*saved-backtrace* (backtrace-as-list-ignoring-swank-calls)))
+ (with-simple-restart (continue "Return from BREAK.")
+ (invoke-debugger
+ (sys::%make-condition 'simple-condition
+ (list :format-control format-control
+ :format-arguments format-arguments))))
+ nil))
+
+(defimplementation make-fn-streams (input-fn output-fn)
+ (let* ((output (ext:make-slime-output-stream output-fn))
+ (input (ext:make-slime-input-stream input-fn output)))
+ (values input output)))
+
+(defimplementation call-with-compilation-hooks (function)
+ (funcall function))
+
+;;; swank-mop
+
+;;dummies and definition
+
+(defclass standard-slot-definition ()())
+
+;(defun class-finalized-p (class) t)
+
+(defun slot-definition-documentation (slot) #+nil (documentation slot 't))
+(defun slot-definition-type (slot) t)
+(defun class-prototype (class))
+(defun generic-function-declarations (gf))
+(defun specializer-direct-methods (spec) (mop::class-direct-methods spec))
+
+(defun slot-definition-name (slot)
+ (mop::%slot-definition-name slot))
+
+(defun class-slots (class)
+ (mop::%class-slots class))
+
+(defun method-generic-function (method)
+ (mop::%method-generic-function method))
+
+(defun method-function (method)
+ (mop::%method-function method))
+
+(defun slot-boundp-using-class (class object slotdef)
+ (system::slot-boundp object (slot-definition-name slotdef)))
+
+(defun slot-value-using-class (class object slotdef)
+ (system::slot-value object (slot-definition-name slotdef)))
+
+(import-to-swank-mop
+ '( ;; classes
+ cl:standard-generic-function
+ standard-slot-definition ;;dummy
+ cl:method
+ cl:standard-class
+ ;; standard-class readers
+ mop::class-default-initargs
+ mop::class-direct-default-initargs
+ mop::class-direct-slots
+ mop::class-direct-subclasses
+ mop::class-direct-superclasses
+ mop::eql-specializer
+ mop::class-finalized-p
+ cl:class-name
+ mop::class-precedence-list
+ class-prototype ;;dummy
+ class-slots
+ specializer-direct-methods
+ ;; eql-specializer accessors
+ mop::eql-specializer-object
+ ;; generic function readers
+ mop::generic-function-argument-precedence-order
+ generic-function-declarations ;;dummy
+ mop::generic-function-lambda-list
+ mop::generic-function-methods
+ mop::generic-function-method-class
+ mop::generic-function-method-combination
+ mop::generic-function-name
+ ;; method readers
+ method-generic-function
+ method-function
+ mop::method-lambda-list
+ mop::method-specializers
+ mop::method-qualifiers
+ ;; slot readers
+ mop::slot-definition-allocation
+ slot-definition-documentation ;;dummy
+ mop::slot-definition-initargs
+ mop::slot-definition-initform
+ mop::slot-definition-initfunction
+ slot-definition-name
+ slot-definition-type ;;dummy
+ mop::slot-definition-readers
+ mop::slot-definition-writers
+ slot-boundp-using-class
+ slot-value-using-class
+ ))
+
+;;;; TCP Server
+
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+
+
+(defimplementation create-socket (host port)
+ (ext:make-server-socket port))
+
+
+(defimplementation local-port (socket)
+ (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
+
+
+(defimplementation close-socket (socket)
+ (ext:server-socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (ext:get-socket-stream (ext:socket-accept socket)))
+
+;;;; Unix signals
+
+(defimplementation call-without-interrupts (fn)
+ (funcall fn))
+
+(defimplementation getpid ()
+ (if (not (find :unix *features*))
+ 0
+ (let* ((runtime
+ (java:jstatic "getRuntime" "java.lang.Runtime"))
+ (command
+ (java:jnew-array-from-array
+ "java.lang.String" #("sh" "-c" "echo $PPID")))
+ (runtime-exec-jmethod
+ ;; Complicated because java.lang.Runtime.exec() is
+ ;; overloaded on a non-primitive type (array of
+ ;; java.lang.String), so we have to use the actual parameter
+ ;; instance to get java.lang.Class
+ (java:jmethod "java.lang.Runtime" "exec"
+ (java:jcall
+ (java:jmethod "java.lang.Object" "getClass")
+ command)))
+ (process
+ (java:jcall runtime-exec-jmethod runtime command))
+ (output
+ (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
+ process)))
+ (java:jcall (java:jmethod "java.lang.Process" "waitFor") process)
+ (loop
+ :with b
+ :do (setq b
+ (java:jcall (java:jmethod "java.io.InputStream" "read")
+ output))
+ :until (member b '(-1 #x0a)) ; Either EOF or LF
+ :collecting (code-char b) :into result
+ :finally (return
+ (values
+ (parse-integer (coerce result 'string))))))))
+
+(defimplementation lisp-implementation-type-name ()
+ "armedbear")
+
+(defimplementation set-default-directory (directory)
+ (let ((dir (sys::probe-directory directory)))
+ (when dir (setf *default-pathname-defaults* dir))
+ (namestring dir)))
+
+
+;;;; Misc
+
+(defimplementation arglist (fun)
+ (cond ((symbolp fun)
+ (multiple-value-bind (arglist present) (sys::arglist fun)
+ (if present arglist :not-available)))
+ (t :not-available)))
+
+(defimplementation function-name (function)
+ (nth-value 2 (function-lambda-expression function)))
+
+(defimplementation macroexpand-all (form)
+ (macroexpand form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+
+;;;; Debugger
+
+(defvar *sldb-topframe*)
+
+(defun backtrace-as-list-ignoring-swank-calls ()
+ (let ((list (ext:backtrace-as-list)))
+ (subseq list (1+ (or (position (intern "SWANK-DEBUGGER-HOOK" 'swank) list :key 'car) -1)))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let ((*sldb-topframe* (car (backtrace-as-list-ignoring-swank-calls)) #+nil (excl::int-newest-frame)))
+ (funcall debugger-loop-fn)))
+
+(defun nth-frame (index)
+ (nth index (backtrace-as-list-ignoring-swank-calls)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (subseq (backtrace-as-list-ignoring-swank-calls) start end)))
+
+(defimplementation print-frame (frame stream)
+ (write-string (string-trim '(#\space #\newline)
+ (prin1-to-string frame))
+ stream))
+
+(defimplementation frame-locals (index)
+ `(,(list :name "??" :id 0 :value "??")))
+
+
+(defimplementation frame-catch-tags (index)
+ (declare (ignore index))
+ nil)
+
+#+nil
+(defimplementation disassemble-frame (index)
+ (disassemble (debugger:frame-function (nth-frame index))))
+
+(defimplementation frame-source-location-for-emacs (index)
+ (list :error (format nil "Cannot find source for frame: ~A"
+ (nth-frame index))))
+
+#+nil
+(defimplementation eval-in-frame (form frame-number)
+ (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame (nth-frame frame-number))))
+
+#+nil
+(defimplementation return-from-frame (frame-number form)
+ (let ((frame (nth-frame frame-number)))
+ (multiple-value-call #'debugger:frame-return
+ frame (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame frame)))))
+
+;;; XXX doesn't work for frames with arguments
+#+nil
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (debugger:frame-retry frame (debugger:frame-function frame))))
+
+;;;; Compiler hooks
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(in-package :swank-backend)
+
+(defun handle-compiler-warning (condition)
+ (let ((loc nil));(getf (slot-value condition 'excl::plist) :loc)))
+ (unless (member condition *abcl-signaled-conditions*) ; filter condition signaled more than once.
+ (push condition *abcl-signaled-conditions*)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "~A" condition)
+ :location (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :position *buffer-start-position*)))
+ (loc
+ (destructuring-bind (file . pos) loc
+ (make-location
+ (list :file (namestring (truename file)))
+ (list :position (1+ pos)))))
+ (t
+ (make-location
+ (list :file *compile-filename*)
+ (list :position 1)))))))))
+
+(defvar *abcl-signaled-conditions*)
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (declare (ignore external-format))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* nil)
+ (*compile-filename* filename))
+ (multiple-value-bind (fn warn fail) (compile-file filename)
+ (when (and load-p (not fail))
+ (load fn)))))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (let ((jvm::*resignal-compiler-warnings* t)
+ (*abcl-signaled-conditions* nil))
+ (handler-bind ((warning #'handle-compiler-warning))
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string))))))))
+
+#|
+;;;; Definition Finding
+
+(defun find-fspec-location (fspec type)
+ (let ((file (excl::fspec-pathname fspec type)))
+ (etypecase file
+ (pathname
+ (let ((start (scm:find-definition-in-file fspec type file)))
+ (make-location (list :file (namestring (truename file)))
+ (if start
+ (list :position (1+ start))
+ (list :function-name (string fspec))))))
+ ((member :top-level)
+ (list :error (format nil "Defined at toplevel: ~A" fspec)))
+ (null
+ (list :error (format nil "Unkown source location for ~A" fspec))))))
+
+(defun fspec-definition-locations (fspec)
+ (let ((defs (excl::find-multiple-definitions fspec)))
+ (loop for (fspec type) in defs
+ collect (list fspec (find-fspec-location fspec type)))))
+
+(defimplementation find-definitions (symbol)
+ (fspec-definition-locations symbol))
+
+|#
+
+(defun source-location (symbol)
+ (when (pathnamep (ext:source-pathname symbol))
+ `(((,symbol)
+ (:location
+ (:file ,(namestring (ext:source-pathname symbol)))
+ (:position ,(or (ext:source-file-position symbol) 0) t)
+ (:snippet nil))))))
+
+
+(defimplementation find-definitions (symbol)
+ (source-location symbol))
+
+#|
+Uncomment this if you have patched xref.lisp, as in
+http://article.gmane.org/gmane.lisp.slime.devel/2425
+Also, make sure that xref.lisp is loaded by modifying the armedbear
+part of *sysdep-pathnames* in swank.loader.lisp.
+
+;;;; XREF
+(setq pxref:*handle-package-forms* '(cl:in-package))
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls pxref:list-callers)
+(defxref who-references pxref:list-readers)
+(defxref who-binds pxref:list-setters)
+(defxref who-sets pxref:list-setters)
+(defxref list-callers pxref:list-callers)
+(defxref list-callees pxref:list-callees)
+
+(defun xref-results (symbols)
+ (let ((xrefs '()))
+ (dolist (symbol symbols)
+ (push (list symbol (cadar (source-location symbol))) xrefs))
+ xrefs))
+|#
+
+;;;; Inspecting
+
+(defclass abcl-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'abcl-inspector))
+
+(defmethod inspect-for-emacs ((slot mop::slot-definition)
+ (inspector backend-inspector))
+ (declare (ignore inspector))
+ (values "A slot."
+ `("Name: " (:value ,(mop::%slot-definition-name slot))
+ (:newline)
+ "Documentation:" (:newline)
+ ,@(when (slot-definition-documentation slot)
+ `((:value ,(slot-definition-documentation slot)) (:newline)))
+ "Initialization:" (:newline)
+ " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
+ " Form: " ,(if (mop::%slot-definition-initfunction slot)
+ `(:value ,(mop::%slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ " Function: " (:value ,(mop::%slot-definition-initfunction slot))
+ (:newline))))
+
+(defmethod inspect-for-emacs ((f function) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (values "A function."
+ `(,@(when (function-name f)
+ `("Name: "
+ ,(princ-to-string (function-name f)) (:newline)))
+ ,@(multiple-value-bind (args present)
+ (sys::arglist f)
+ (when present `("Argument list: " ,(princ-to-string args) (:newline))))
+ (:newline)
+ #+nil,@(when (documentation f t)
+ `("Documentation:" (:newline) ,(documentation f t) (:newline)))
+ ,@(when (function-lambda-expression f)
+ `("Lambda expression:"
+ (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))))
+
+#|
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (let* ((class (class-of o))
+ (slots (mop::class-slots class)))
+ (values (format nil "~A~% is a ~A" o class)
+ (mapcar (lambda (slot)
+ (let ((name (mop::slot-definition-name slot)))
+ (cons (princ-to-string name)
+ (slot-value o name))))
+ slots))))
+|#
+
+;;;; Multithreading
+
+(defimplementation startup-multiprocessing ()
+ #+nil(mp:start-scheduler))
+
+(defimplementation spawn (fn &key name)
+ (ext:make-thread (lambda () (funcall fn)) :name name))
+
+(defvar *thread-props-lock* (ext:make-thread-lock))
+
+(defvar *thread-props* (make-hash-table) ; should be a weak table
+ "A hashtable mapping threads to a plist.")
+
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (ext:with-thread-lock (*thread-props-lock*)
+ (or (getf (gethash thread *thread-props*) 'id)
+ (setf (getf (gethash thread *thread-props*) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (thread)
+ (getf (gethash thread *thread-props*) 'id))))
+
+(defimplementation thread-name (thread)
+ (ext:thread-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "Thread is ~:[dead~;alive~]" (ext:thread-alive-p thread)))
+
+(defimplementation make-lock (&key name)
+ (ext:make-thread-lock))
+
+(defimplementation call-with-lock-held (lock function)
+ (ext:with-thread-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ (ext:current-thread))
+
+(defimplementation all-threads ()
+ (copy-list (ext:mapcar-threads #'identity)))
+
+(defimplementation interrupt-thread (thread fn)
+ (ext:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+ (ext:destroy-thread thread))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (ext:with-thread-lock (*thread-props-lock*)
+ (or (getf (gethash thread *thread-props*) 'mailbox)
+ (setf (getf (gethash thread *thread-props*) 'mailbox)
+ (ext:make-mailbox)))))
+
+(defimplementation send (thread object)
+ (ext:mailbox-send (mailbox thread) object))
+
+(defimplementation receive ()
+ (ext:mailbox-read (mailbox (ext:current-thread))))
+
+;;; Auto-flush streams
+
+;; XXX race conditions
+(defvar *auto-flush-streams* '())
+
+(defvar *auto-flush-thread* nil)
+
+(defimplementation make-stream-interactive (stream)
+ (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
+ (unless *auto-flush-thread*
+ (setq *auto-flush-thread*
+ (ext:make-thread #'flush-streams
+ :name "auto-flush-thread"))))
+
+(defun flush-streams ()
+ (loop
+ (setq *auto-flush-streams*
+ (remove-if (lambda (x)
+ (not (and (open-stream-p x)
+ (output-stream-p x))))
+ *auto-flush-streams*))
+ (mapc #'finish-output *auto-flush-streams*)
+ (sleep 0.15)))
+
+(defimplementation quit-lisp ()
+ (ext:exit))
+
+;; WORKAROUND: call/initialize accessors at load time
+(let ((c (make-condition 'compiler-condition
+ :original-condition nil
+ :severity ':note :message "" :location nil))
+ (slots `(severity message short-message references location)))
+ (dolist (slot slots)
+ (funcall slot c)))
Added: branches/bos/thirdparty/emacs/slime/swank-allegro.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-allegro.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,774 @@
+;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
+;;;
+;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
+;;;
+;;; Created 2003
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package :swank-backend)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sock)
+ (require :process))
+
+(import-from :excl *gray-stream-symbols* :swank-backend)
+
+;;; swank-mop
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+
+;;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port)
+ (socket:make-socket :connect :passive :local-port port
+ :local-host host :reuse-address t))
+
+(defimplementation local-port (socket)
+ (socket:local-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket &key external-format buffering
+ timeout)
+ (declare (ignore buffering timeout))
+ (let ((s (socket:accept-connection socket :wait t)))
+ (when external-format
+ (setf (stream-external-format s) external-format))
+ s))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")
+ (:emacs-mule "emacs-mule" "emacs-mule-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+ (and e (excl:crlf-base-ef
+ (excl:find-external-format (car e)
+ :try-variant t)))))
+
+(defimplementation format-sldb-condition (c)
+ (princ-to-string c))
+
+(defimplementation call-with-syntax-hooks (fn)
+ (funcall fn))
+
+;;;; Unix signals
+
+(defimplementation call-without-interrupts (fn)
+ (excl:without-interrupts (funcall fn)))
+
+(defimplementation getpid ()
+ (excl::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "allegro")
+
+(defimplementation set-default-directory (directory)
+ (let* ((dir (namestring (truename (merge-pathnames directory)))))
+ (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
+ dir))
+
+(defimplementation default-directory ()
+ (namestring (excl:current-directory)))
+
+;;;; Misc
+
+(defimplementation arglist (symbol)
+ (handler-case (excl:arglist symbol)
+ (simple-error () :not-available)))
+
+(defimplementation macroexpand-all (form)
+ (excl::walk form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+(defimplementation make-stream-interactive (stream)
+ (setf (interactive-stream-p stream) t))
+
+;;;; Debugger
+
+(defvar *sldb-topframe*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let ((*sldb-topframe* (find-topframe))
+ (excl::*break-hook* nil))
+ (funcall debugger-loop-fn)))
+
+(defimplementation sldb-break-at-start (fname)
+ ;; :print-before is kind of mis-used but we just want to stuff our break form
+ ;; somewhere. This does not work for setf, :before and :after methods, which
+ ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10.
+ (eval `(trace (,fname
+ :print-before
+ ((break "Function start breakpoint of ~A" ',fname)))))
+ `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
+
+(defun find-topframe ()
+ (let ((skip-frames 3))
+ (do ((f (excl::int-newest-frame) (next-frame f))
+ (i 0 (1+ i)))
+ ((= i skip-frames) f))))
+
+(defun next-frame (frame)
+ (let ((next (excl::int-next-older-frame frame)))
+ (cond ((not next) nil)
+ ((debugger:frame-visible-p next) next)
+ (t (next-frame next)))))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-topframe* (next-frame frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (next-frame f)
+ for i from start below end
+ while f
+ collect f)))
+
+(defimplementation print-frame (frame stream)
+ (debugger:output-frame stream frame :moderate))
+
+(defimplementation frame-locals (index)
+ (let ((frame (nth-frame index)))
+ (loop for i from 0 below (debugger:frame-number-vars frame)
+ collect (list :name (debugger:frame-var-name frame i)
+ :id 0
+ :value (debugger:frame-var-value frame i)))))
+
+(defimplementation frame-var-value (frame var)
+ (let ((frame (nth-frame frame)))
+ (debugger:frame-var-value frame var)))
+
+(defimplementation frame-catch-tags (index)
+ (declare (ignore index))
+ nil)
+
+(defimplementation disassemble-frame (index)
+ (disassemble (debugger:frame-function (nth-frame index))))
+
+(defimplementation frame-source-location-for-emacs (index)
+ (let* ((frame (nth-frame index))
+ (expr (debugger:frame-expression frame))
+ (fspec (first expr)))
+ (second (first (fspec-definition-locations fspec)))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (nth-frame frame-number)))
+ ;; let-bind lexical variables
+ (let ((vars (loop for i below (debugger:frame-number-vars frame)
+ for name = (debugger:frame-var-name frame i)
+ if (symbolp name)
+ collect `(,name ',(debugger:frame-var-value frame i)))))
+ (debugger:eval-form-in-context
+ `(let* ,vars ,form)
+ (debugger:environment-of-frame frame)))))
+
+(defimplementation return-from-frame (frame-number form)
+ (let ((frame (nth-frame frame-number)))
+ (multiple-value-call #'debugger:frame-return
+ frame (debugger:eval-form-in-context
+ form
+ (debugger:environment-of-frame frame)))))
+
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (cond ((debugger:frame-retryable-p frame)
+ (apply #'debugger:frame-retry frame (debugger:frame-function frame)
+ (cdr (debugger:frame-expression frame))))
+ (t "Frame is not retryable"))))
+
+;;;; Compiler hooks
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+(defun compiler-note-p (object)
+ (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
+
+(defun compiler-undefined-functions-called-warning-p (object)
+ (typep object 'excl:compiler-undefined-functions-called-warning))
+
+(deftype compiler-note ()
+ `(satisfies compiler-note-p))
+
+(defun signal-compiler-condition (&rest args)
+ (signal (apply #'make-condition 'compiler-condition args)))
+
+(defun handle-compiler-warning (condition)
+ (declare (optimize (debug 3) (speed 0) (space 0)))
+ (cond ((and (not *buffer-name*)
+ (compiler-undefined-functions-called-warning-p condition))
+ (handle-undefined-functions-warning condition))
+ (t
+ (signal-compiler-condition
+ :original-condition condition
+ :severity (etypecase condition
+ (warning :warning)
+ (compiler-note :note))
+ :message (format nil "~A" condition)
+ :location (location-for-warning condition)))))
+
+(defun location-for-warning (condition)
+ (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :position *buffer-start-position*)))
+ (loc
+ (destructuring-bind (file . pos) loc
+ (make-location
+ (list :file (namestring (truename file)))
+ (list :position (1+ pos)))))
+ (t
+ (list :error "No error location available.")))))
+
+(defun handle-undefined-functions-warning (condition)
+ (let ((fargs (slot-value condition 'excl::format-arguments)))
+ (loop for (fname . pos-file) in (car fargs) do
+ (loop for (pos file) in pos-file do
+ (signal-compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (format nil "Undefined function referenced: ~S"
+ fname)
+ :location (make-location (list :file file)
+ (list :position (1+ pos))))))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((warning #'handle-compiler-warning)
+ ;;(compiler-note #'handle-compiler-warning)
+ )
+ (funcall function)))
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*compile-filename* filename))
+ (compile-file *compile-filename* :load-after-compile load-p
+ :external-format external-format))))
+
+(defun call-with-temp-file (fn)
+ (let ((tmpname (system:make-temp-file-name)))
+ (unwind-protect
+ (with-open-file (file tmpname :direction :output :if-exists :error)
+ (funcall fn file tmpname))
+ (delete-file tmpname))))
+
+(defun compile-from-temp-file (string)
+ (call-with-temp-file
+ (lambda (stream filename)
+ (write-string string stream)
+ (finish-output stream)
+ (let ((binary-filename
+ (excl:without-redefinition-warnings
+ ;; Suppress Allegro's redefinition warnings; they are
+ ;; pointless when we are compiling via a temporary
+ ;; file.
+ (compile-file filename :load-after-compile t))))
+ (when binary-filename
+ (delete-file binary-filename))))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ ;; We store the source buffer in excl::*source-pathname* as a string
+ ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
+ ;; the fasl file is corrupted if we use some other datatype.
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string)
+ (*default-pathname-defaults*
+ (if directory (merge-pathnames (pathname directory))
+ *default-pathname-defaults*)))
+ (compile-from-temp-file
+ (format nil "~S ~S~%~A"
+ `(in-package ,(package-name *package*))
+ `(eval-when (:compile-toplevel :load-toplevel)
+ (setq excl::*source-pathname*
+ ',(format nil "~A;~D" buffer position)))
+ string)))))
+
+;;;; Definition Finding
+
+(defun fspec-primary-name (fspec)
+ (etypecase fspec
+ (symbol fspec)
+ (list (fspec-primary-name (second fspec)))))
+
+;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
+;; single character, but file-position counts them as two. Here we do
+;; our own conversion.
+(defun count-cr (file pos)
+ (let* ((bufsize 256)
+ (type '(unsigned-byte 8))
+ (buf (make-array bufsize :element-type type))
+ (cr-count 0))
+ (with-open-file (stream file :direction :input :element-type type)
+ (loop for bytes-read = (read-sequence buf stream) do
+ (incf cr-count (count (char-code #\return) buf
+ :end (min pos bytes-read)))
+ (decf pos bytes-read)
+ (when (<= pos 0)
+ (return cr-count))))))
+
+(defun find-definition-in-file (fspec type file top-level)
+ (let* ((part
+ (or (scm::find-definition-in-definition-group
+ fspec type (scm:section-file :file file)
+ :top-level top-level)
+ (scm::find-definition-in-definition-group
+ (fspec-primary-name fspec)
+ type (scm:section-file :file file)
+ :top-level top-level)))
+ (start (and part
+ (scm::source-part-start part)))
+ (pos (if start
+ (list :position (1+ (- start (count-cr file start))))
+ (list :function-name (string (fspec-primary-name fspec))))))
+ (make-location (list :file (namestring (truename file)))
+ pos)))
+
+(defun find-definition-in-buffer (filename)
+ (let ((pos (position #\; filename :from-end t)))
+ (make-location
+ (list :buffer (subseq filename 0 pos))
+ (list :position (parse-integer (subseq filename (1+ pos)))))))
+
+(defun find-fspec-location (fspec type file top-level)
+ (etypecase file
+ (pathname
+ (find-definition-in-file fspec type file top-level))
+ ((member :top-level)
+ (list :error (format nil "Defined at toplevel: ~A"
+ (fspec->string fspec))))
+ (string
+ (find-definition-in-buffer file))))
+
+(defun fspec->string (fspec)
+ (etypecase fspec
+ (symbol (let ((*package* (find-package :keyword)))
+ (prin1-to-string fspec)))
+ (list (format nil "(~A ~A)"
+ (prin1-to-string (first fspec))
+ (let ((*package* (find-package :keyword)))
+ (prin1-to-string (second fspec)))))))
+
+(defun fspec-definition-locations (fspec)
+ (cond
+ ((and (listp fspec)
+ (eql (car fspec) :top-level-form))
+ (destructuring-bind (top-level-form file &optional position) fspec
+ (list
+ (list (list nil fspec)
+ (make-location (list :buffer file)
+ (list :position position t))))))
+ ((and (listp fspec) (eq (car fspec) :internal))
+ (destructuring-bind (_internal next _n) fspec
+ (fspec-definition-locations next)))
+ (t
+ (let ((defs (excl::find-source-file fspec)))
+ (if (null defs)
+ (list
+ (list (list nil fspec)
+ (list :error
+ (format nil "Unknown source location for ~A"
+ (fspec->string fspec)))))
+ (loop for (fspec type file top-level) in defs
+ collect (list (list type fspec)
+ (find-fspec-location fspec type file top-level))))))))
+
+(defimplementation find-definitions (symbol)
+ (fspec-definition-locations symbol))
+
+;;;; XREF
+
+(defmacro defxref (name relation name1 name2)
+ `(defimplementation ,name (x)
+ (xref-result (xref:get-relation ,relation ,name1 ,name2))))
+
+(defxref who-calls :calls :wild x)
+(defxref calls-who :calls x :wild)
+(defxref who-references :uses :wild x)
+(defxref who-binds :binds :wild x)
+(defxref who-macroexpands :macro-calls :wild x)
+(defxref who-sets :sets :wild x)
+
+(defun xref-result (fspecs)
+ (loop for fspec in fspecs
+ append (fspec-definition-locations fspec)))
+
+;; list-callers implemented by groveling through all fbound symbols.
+;; Only symbols are considered. Functions in the constant pool are
+;; searched recursively. Closure environments are ignored at the
+;; moment (constants in methods are therefore not found).
+
+(defun map-function-constants (function fn depth)
+ "Call FN with the elements of FUNCTION's constant pool."
+ (do ((i 0 (1+ i))
+ (max (excl::function-constant-count function)))
+ ((= i max))
+ (let ((c (excl::function-constant function i)))
+ (cond ((and (functionp c)
+ (not (eq c function))
+ (plusp depth))
+ (map-function-constants c fn (1- depth)))
+ (t
+ (funcall fn c))))))
+
+(defun in-constants-p (fun symbol)
+ (map-function-constants fun
+ (lambda (c)
+ (when (eq c symbol)
+ (return-from in-constants-p t)))
+ 3))
+
+(defun function-callers (name)
+ (let ((callers '()))
+ (do-all-symbols (sym)
+ (when (fboundp sym)
+ (let ((fn (fdefinition sym)))
+ (when (in-constants-p fn name)
+ (push sym callers)))))
+ callers))
+
+(defimplementation list-callers (name)
+ (xref-result (function-callers name)))
+
+(defimplementation list-callees (name)
+ (let ((result '()))
+ (map-function-constants (fdefinition name)
+ (lambda (c)
+ (when (fboundp c)
+ (push c result)))
+ 2)
+ (xref-result result)))
+
+;;;; Profiling
+
+;; Per-function profiling based on description in
+;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#dat…
+
+(defvar *profiled-functions* ())
+(defvar *profile-depth* 0)
+
+(defmacro with-redirected-y-or-n-p (&body body)
+ ;; If the profiler is restarted when the data from the previous
+ ;; session is not reported yet, the user is warned via Y-OR-N-P.
+ ;; As the CL:Y-OR-N-P question is (for some reason) not directly
+ ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
+ ;; overruled.
+ `(let* ((pkg (find-package "common-lisp"))
+ (saved-pdl (excl::package-definition-lock pkg))
+ (saved-ynp (symbol-function 'cl:y-or-n-p)))
+
+ (setf (excl::package-definition-lock pkg) nil
+ (symbol-function 'cl:y-or-n-p) (symbol-function
+ (find-symbol "y-or-n-p-in-emacs"
+ "swank")))
+ (unwind-protect
+ (progn ,@body)
+
+ (setf (symbol-function 'cl:y-or-n-p) saved-ynp
+ (excl::package-definition-lock pkg) saved-pdl))))
+
+(defun start-acl-profiler ()
+ (with-redirected-y-or-n-p
+ (prof:start-profiler :type :time :count t
+ :start-sampling-p nil :verbose nil)))
+(defun acl-profiler-active-p ()
+ (not (eq (prof:profiler-status :verbose nil) :inactive)))
+
+(defun stop-acl-profiler ()
+ (prof:stop-profiler :verbose nil))
+
+(excl:def-fwrapper profile-fwrapper (&rest args)
+ ;; Ensures sampling is done during the execution of the function,
+ ;; taking into account recursion.
+ (declare (ignore args))
+ (cond ((zerop *profile-depth*)
+ (let ((*profile-depth* (1+ *profile-depth*)))
+ (prof:start-sampling)
+ (unwind-protect (excl:call-next-fwrapper)
+ (prof:stop-sampling))))
+ (t
+ (excl:call-next-fwrapper))))
+
+(defimplementation profile (fname)
+ (unless (acl-profiler-active-p)
+ (start-acl-profiler))
+ (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
+ (push fname *profiled-functions*))
+
+(defimplementation profiled-functions ()
+ *profiled-functions*)
+
+(defimplementation unprofile (fname)
+ (excl:funwrap fname 'profile-fwrapper)
+ (setq *profiled-functions* (remove fname *profiled-functions*)))
+
+(defimplementation profile-report ()
+ (prof:show-flat-profile :verbose nil)
+ (when *profiled-functions*
+ (start-acl-profiler)))
+
+(defimplementation profile-reset ()
+ (when (acl-profiler-active-p)
+ (stop-acl-profiler)
+ (start-acl-profiler))
+ "Reset profiling counters.")
+
+;;;; Inspecting
+
+(defclass acl-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'acl-inspector))
+
+(defmethod inspect-for-emacs ((f function) inspector)
+ inspector
+ (values "A function."
+ (append
+ (label-value-line "Name" (function-name f))
+ `("Formals" ,(princ-to-string (arglist f)) (:newline))
+ (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
+ (when doc
+ `("Documentation:" (:newline) ,doc))))))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ inspector
+ (values "A value." (allegro-inspect o)))
+
+(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
+ inspector
+ (values "A function." (allegro-inspect o)))
+
+(defmethod inspect-for-emacs ((o standard-object)
+ (inspector backend-inspector))
+ inspector
+ (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
+
+(defun allegro-inspect (o)
+ (loop for (d dd) on (inspect::inspect-ctl o)
+ append (frob-allegro-field-def o d)
+ until (eq d dd)))
+
+(defun frob-allegro-field-def (object def)
+ (with-struct (inspect::field-def- name type access) def
+ (ecase type
+ ((:unsigned-word :unsigned-byte :unsigned-natural
+ :unsigned-long :unsigned-half-long
+ :unsigned-3byte)
+ (label-value-line name (inspect::component-ref-v object access type)))
+ ((:lisp :value)
+ (label-value-line name (inspect::component-ref object access)))
+ (:indirect
+ (destructuring-bind (prefix count ref set) access
+ (declare (ignore set prefix))
+ (loop for i below (funcall count object)
+ append (label-value-line (format nil "~A-~D" name i)
+ (funcall ref object i))))))))
+
+;;;; Multithreading
+
+(defimplementation initialize-multiprocessing (continuation)
+ (mp:start-scheduler)
+ (funcall continuation))
+
+(defimplementation spawn (fn &key name)
+ (mp:process-run-function name fn))
+
+(defvar *id-lock* (mp:make-process-lock :name "id lock"))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (mp:with-process-lock (*id-lock*)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id mp:*all-processes*
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
+(defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "~A ~D" (mp:process-whostate thread)
+ (mp:process-priority thread)))
+
+(defimplementation make-lock (&key name)
+ (mp:make-process-lock :name name))
+
+(defimplementation call-with-lock-held (lock function)
+ (mp:with-process-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mp:*current-process*)
+
+(defimplementation all-threads ()
+ (copy-list mp:*all-processes*))
+
+(defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+(defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+(defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ (mutex (mp:make-process-lock :name "process mailbox"))
+ (queue '() :type list))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-process-lock (*mailbox-lock*)
+ (or (getf (mp:process-property-list thread) 'mailbox)
+ (setf (getf (mp:process-property-list thread) 'mailbox)
+ (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (mp:process-wait-with-timeout
+ "yielding before sending" 0.1
+ (lambda ()
+ (mp:with-process-lock (mutex)
+ (< (length (mailbox.queue mbox)) 10))))
+ (mp:with-process-lock (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+(defimplementation receive ()
+ (let* ((mbox (mailbox mp:*current-process*))
+ (mutex (mailbox.mutex mbox)))
+ (mp:process-wait "receive" #'mailbox.queue mbox)
+ (mp:with-process-lock (mutex)
+ (pop (mailbox.queue mbox)))))
+
+(defimplementation quit-lisp ()
+ (excl:exit 0 :quiet t))
+
+
+;;Trace implementations
+;;In Allegro 7.0, we have:
+;; (trace <name>)
+;; (trace ((method <name> <qualifier>? (<specializer>+))))
+;; (trace ((labels <name> <label-name>)))
+;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
+;; <name> can be a normal name or a (setf name)
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ (:defgeneric (toggle-trace-generic-function-methods (second spec)))
+ ((setf :defmethod :labels :flet)
+ (toggle-trace-aux (process-fspec-for-allegro spec)))
+ (:call
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux callee
+ :inside (list (process-fspec-for-allegro caller)))))))
+
+(defun tracedp (fspec)
+ (member fspec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (fspec &rest args)
+ (cond ((tracedp fspec)
+ (eval `(untrace ,fspec))
+ (format nil "~S is now untraced." fspec))
+ (t
+ (eval `(trace (,fspec ,@args)))
+ (format nil "~S is now traced." fspec))))
+
+(defun toggle-trace-generic-function-methods (name)
+ (let ((methods (mop:generic-function-methods (fdefinition name))))
+ (cond ((tracedp name)
+ (eval `(untrace ,name))
+ (dolist (method methods (format nil "~S is now untraced." name))
+ (excl:funtrace (mop:method-function method))))
+ (t
+ (eval `(trace (,name)))
+ (dolist (method methods (format nil "~S is now traced." name))
+ (excl:ftrace (mop:method-function method)))))))
+
+(defun process-fspec-for-allegro (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((setf) fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod) `(method ,@(rest fspec)))
+ ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
+ ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
+ ,(third fspec)))))
+ (t
+ fspec)))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-keys t args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :values :weak args))
+
+(defimplementation hash-table-weakness (hashtable)
+ (cond ((excl:hash-table-weak-keys hashtable) :key)
+ ((eq (excl:hash-table-values hashtable) :weak) :value)))
+
+
+
+;;;; Character names
+
+(defimplementation character-completion-set (prefix matchp)
+ (loop for name being the hash-keys of excl::*name-to-char-table*
+ when (funcall matchp prefix name)
+ collect (string-capitalize name)))
Added: branches/bos/thirdparty/emacs/slime/swank-backend.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-backend.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,1077 @@
+;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
+;;;
+;;; slime-backend.lisp --- SLIME backend interface.
+;;;
+;;; Created by James Bielman in 2003. Released into the public domain.
+;;;
+;;;; Frontmatter
+;;;
+;;; This file defines the functions that must be implemented
+;;; separately for each Lisp. Each is declared as a generic function
+;;; for which swank-<implementation>.lisp provides methods.
+
+(defpackage :swank-backend
+ (:use :common-lisp)
+ (:export #:sldb-condition
+ #:original-condition
+ #:compiler-condition
+ #:message
+ #:short-message
+ #:condition
+ #:severity
+ #:with-compilation-hooks
+ #:location
+ #:location-p
+ #:location-buffer
+ #:location-position
+ #:position-p
+ #:position-pos
+ #:print-output-to-string
+ #:quit-lisp
+ #:references
+ #:unbound-slot-filler
+ #:declaration-arglist
+ #:type-specifier-arglist
+ ;; inspector related symbols
+ #:inspector
+ #:backend-inspector
+ #:inspect-for-emacs
+ #:raw-inspection
+ #:fancy-inspection
+ #:label-value-line
+ #:label-value-line*
+ #:with-struct
+ ))
+
+(defpackage :swank-mop
+ (:use)
+ (:export
+ ;; classes
+ #:standard-generic-function
+ #:standard-slot-definition
+ #:standard-method
+ #:standard-class
+ #:eql-specializer
+ #:eql-specializer-object
+ ;; standard-class readers
+ #:class-default-initargs
+ #:class-direct-default-initargs
+ #:class-direct-slots
+ #:class-direct-subclasses
+ #:class-direct-superclasses
+ #:class-finalized-p
+ #:class-name
+ #:class-precedence-list
+ #:class-prototype
+ #:class-slots
+ #:specializer-direct-methods
+ ;; generic function readers
+ #:generic-function-argument-precedence-order
+ #:generic-function-declarations
+ #:generic-function-lambda-list
+ #:generic-function-methods
+ #:generic-function-method-class
+ #:generic-function-method-combination
+ #:generic-function-name
+ ;; method readers
+ #:method-generic-function
+ #:method-function
+ #:method-lambda-list
+ #:method-specializers
+ #:method-qualifiers
+ ;; slot readers
+ #:slot-definition-allocation
+ #:slot-definition-documentation
+ #:slot-definition-initargs
+ #:slot-definition-initform
+ #:slot-definition-initfunction
+ #:slot-definition-name
+ #:slot-definition-type
+ #:slot-definition-readers
+ #:slot-definition-writers
+ #:slot-boundp-using-class
+ #:slot-value-using-class
+ #:slot-makunbound-using-class
+ ;; generic function protocol
+ #:compute-applicable-methods-using-classes
+ #:finalize-inheritance))
+
+(in-package :swank-backend)
+
+
+;;;; 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 &rest default-body)
+ "Define an interface function for the backend to implement.
+A function is defined with NAME, ARGS, and DOCUMENTATION. This
+function first looks for a function to call in NAME's property list
+that is indicated by 'IMPLEMENTATION; failing that, it looks for a
+function indicated by 'DEFAULT. If neither is present, an error is
+signaled.
+
+If a DEFAULT-BODY is supplied, then a function with the same body and
+ARGS will be added to NAME's property list as the property indicated
+by 'DEFAULT.
+
+Backends implement these functions using DEFIMPLEMENTATION."
+ (check-type documentation string "a documentation string")
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ (labels ((gen-default-impl ()
+ `(setf (get ',name 'default) (lambda ,args ,@default-body)))
+ (args-as-list (args)
+ (destructuring-bind (req opt key rest) (parse-lambda-list args)
+ `(,@req ,@opt
+ ,@(loop for k in key append `(,(kw k) ,k))
+ ,@(or rest '(())))))
+ (parse-lambda-list (args)
+ (parse args '(&optional &key &rest)
+ (make-array 4 :initial-element nil)))
+ (parse (args keywords vars)
+ (cond ((null args)
+ (reverse (map 'list #'reverse vars)))
+ ((member (car args) keywords)
+ (parse (cdr args) (cdr (member (car args) keywords)) vars))
+ (t (push (car args) (aref vars (length keywords)))
+ (parse (cdr args) keywords vars))))
+ (kw (s) (intern (string s) :keyword)))
+ `(progn
+ (defun ,name ,args
+ ,documentation
+ (let ((f (or (get ',name 'implementation)
+ (get ',name 'default))))
+ (cond (f (apply f ,@(args-as-list args)))
+ (t (error "~S not implementated" ',name)))))
+ (pushnew ',name *interface-functions*)
+ ,(if (null default-body)
+ `(pushnew ',name *unimplemented-interfaces*)
+ (gen-default-impl))
+ ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler…>
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',name :swank-backend))
+ ',name)))
+
+(defmacro defimplementation (name args &body body)
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ `(progn
+ (setf (get ',name 'implementation) (lambda ,args ,@body))
+ (if (member ',name *interface-functions*)
+ (setq *unimplemented-interfaces*
+ (remove ',name *unimplemented-interfaces*))
+ (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
+ ',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<)))
+
+(defun import-to-swank-mop (symbol-list)
+ (dolist (sym symbol-list)
+ (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
+ (when swank-mop-sym
+ (unintern swank-mop-sym :swank-mop))
+ (import sym :swank-mop)
+ (export sym :swank-mop))))
+
+(defun import-swank-mop-symbols (package except)
+ "Import the mop symbols from PACKAGE to SWANK-MOP.
+EXCEPT is a list of symbol names which should be ignored."
+ (do-symbols (s :swank-mop)
+ (unless (member s except :test #'string=)
+ (let ((real-symbol (find-symbol (string s) package)))
+ (assert real-symbol () "Symbol ~A not found in package ~A" s package)
+ (unintern s :swank-mop)
+ (import real-symbol :swank-mop)
+ (export real-symbol :swank-mop)))))
+
+(defvar *gray-stream-symbols*
+ '(:fundamental-character-output-stream
+ :stream-write-char
+ :stream-fresh-line
+ :stream-force-output
+ :stream-finish-output
+ :fundamental-character-input-stream
+ :stream-read-char
+ :stream-listen
+ :stream-unread-char
+ :stream-clear-input
+ :stream-line-column
+ :stream-read-char-no-hang
+ ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
+ ;; supported by CMUCL, OpenMCL, SBCL and SCL.
+ #+(or cmu openmcl sbcl scl)
+ :stream-line-length))
+
+(defun import-from (package symbol-names &optional (to-package *package*))
+ "Import the list of SYMBOL-NAMES found in the package PACKAGE."
+ (dolist (name symbol-names)
+ (multiple-value-bind (symbol found) (find-symbol (string name) package)
+ (assert found () "Symbol ~A not found in package ~A" name package)
+ (import symbol to-package))))
+
+
+;;;; Utilities
+
+(defmacro with-struct ((conc-name &rest names) obj &body body)
+ "Like with-slots but works only for structs."
+ (flet ((reader (slot) (intern (concatenate 'string
+ (symbol-name conc-name)
+ (symbol-name slot))
+ (symbol-package conc-name))))
+ (let ((tmp (gensym "OO-")))
+ ` (let ((,tmp ,obj))
+ (symbol-macrolet
+ ,(loop for name in names collect
+ (typecase name
+ (symbol `(,name (,(reader name) ,tmp)))
+ (cons `(,(first name) (,(reader (second name)) ,tmp)))
+ (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
+ ,@body)))))
+
+
+;;;; TCP server
+
+(definterface create-socket (host port)
+ "Create a listening TCP socket on interface HOST and port PORT .")
+
+(definterface local-port (socket)
+ "Return the local port number of SOCKET.")
+
+(definterface close-socket (socket)
+ "Close the socket SOCKET.")
+
+(definterface accept-connection (socket &key external-format
+ buffering timeout)
+ "Accept a client connection on the listening socket SOCKET.
+Return a stream for the new connection.")
+
+(definterface add-sigio-handler (socket fn)
+ "Call FN whenever SOCKET is readable.")
+
+(definterface remove-sigio-handlers (socket)
+ "Remove all sigio handlers for SOCKET.")
+
+(definterface add-fd-handler (socket fn)
+ "Call FN when Lisp is waiting for input and SOCKET is readable.")
+
+(definterface remove-fd-handlers (socket)
+ "Remove all fd-handlers for SOCKET.")
+
+(definterface preferred-communication-style ()
+ "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
+ nil)
+
+(definterface set-stream-timeout (stream timeout)
+ "Set the 'stream 'timeout. The timeout is either the real number
+ specifying the timeout in seconds or 'nil for no timeout."
+ (declare (ignore stream timeout))
+ nil)
+
+;;; Base condition for networking errors.
+(define-condition network-error (simple-error) ())
+
+(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."
+ nil)
+
+
+;;;; Unix signals
+
+(defconstant +sigint+ 2)
+
+(definterface call-without-interrupts (fn)
+ "Call FN in a context where interrupts are disabled."
+ (funcall fn))
+
+(definterface getpid ()
+ "Return the (Unix) process ID of this superior Lisp.")
+
+(definterface lisp-implementation-type-name ()
+ "Return a short name for the Lisp implementation."
+ (lisp-implementation-type))
+
+(definterface default-directory ()
+ "Return the default directory."
+ (directory-namestring (truename *default-pathname-defaults*)))
+
+(definterface set-default-directory (directory)
+ "Set the default directory.
+This is used to resolve filenames without directory component."
+ (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
+ (default-directory))
+
+(definterface call-with-syntax-hooks (fn)
+ "Call FN with hooks to handle special syntax."
+ (funcall fn))
+
+(definterface default-readtable-alist ()
+ "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
+ '())
+
+(definterface quit-lisp ()
+ "Exit the current lisp image.")
+
+
+;;;; Compilation
+
+(definterface call-with-compilation-hooks (func)
+ "Call FUNC with hooks to record compiler conditions.")
+
+(defmacro with-compilation-hooks ((&rest ignore) &body body)
+ "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
+ (declare (ignore ignore))
+ `(call-with-compilation-hooks (lambda () (progn ,@body))))
+
+(definterface swank-compile-string (string &key buffer position directory)
+ "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.
+
+If DIRECTORY is specified it may be used by certain implementations to
+rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
+source information.")
+
+(definterface swank-compile-file (filename load-p external-format)
+ "Compile FILENAME signalling COMPILE-CONDITIONs.
+If LOAD-P is true, load the file after compilation.
+EXTERNAL-FORMAT is a value returned by find-external-format or
+:default.")
+
+(deftype severity ()
+ '(member :error :read-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)
+
+ (short-message :initarg :short-message
+ :initform nil
+ :accessor short-message)
+
+ (references :initarg :references
+ :initform nil
+ :accessor references)
+
+ (location :initarg :location
+ :accessor location)))
+
+(definterface find-external-format (coding-system)
+ "Return a \"external file format designator\" for CODING-SYSTEM.
+CODING-SYSTEM is Emacs-style coding system name (a string),
+e.g. \"latin-1-unix\"."
+ (if (equal coding-system "iso-latin-1-unix")
+ :default
+ nil))
+
+(definterface guess-external-format (filename)
+ "Detect the external format for the file with name FILENAME.
+Return nil if the file contains no special markers."
+ ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
+ (with-open-file (s filename :if-does-not-exist nil
+ :external-format (or (find-external-format "latin-1-unix")
+ :default))
+ (if s
+ (or (let* ((line (read-line s nil))
+ (p (search "-*-" line)))
+ (when p
+ (let* ((start (+ p (length "-*-")))
+ (end (search "-*-" line :start2 start)))
+ (when end
+ (%search-coding line start end)))))
+ (let* ((len (file-length s))
+ (buf (make-string (min len 3000))))
+ (file-position s (- len (length buf)))
+ (read-sequence buf s)
+ (let ((start (search "Local Variables:" buf :from-end t))
+ (end (search "End:" buf :from-end t)))
+ (and start end (< start end)
+ (%search-coding buf start end))))))))
+
+(defun %search-coding (str start end)
+ (let ((p (search "coding:" str :start2 start :end2 end)))
+ (when p
+ (incf p (length "coding:"))
+ (loop while (and (< p end)
+ (member (aref str p) '(#\space #\tab)))
+ do (incf p))
+ (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
+ str :start p)))
+ (find-external-format (subseq str p end))))))
+
+
+;;;; Streams
+
+(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.
+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.")
+
+(definterface make-stream-interactive (stream)
+ "Do any necessary setup to make STREAM work interactively.
+This is called for each stream used for interaction with the user
+\(e.g. *standard-output*). An implementation could setup some
+implementation-specific functions to control output flushing at the
+like."
+ (declare (ignore stream))
+ nil)
+
+
+;;;; Documentation
+
+(definterface arglist (name)
+ "Return the lambda list for the symbol NAME. NAME can also be
+a lisp function object, on lisps which support this.
+
+The result can be a list or the :not-available keyword if the
+arglist cannot be determined."
+ (declare (ignore name))
+ :not-available)
+
+(defgeneric declaration-arglist (decl-identifier)
+ (:documentation
+ "Return the argument list of the declaration specifier belonging to the
+declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
+the keyword :NOT-AVAILABLE is returned.
+
+The different SWANK backends can specialize this generic function to
+include implementation-dependend declaration specifiers, or to provide
+additional information on the specifiers defined in ANSI Common Lisp.")
+ (:method (decl-identifier)
+ (case decl-identifier
+ (dynamic-extent '(&rest vars))
+ (ignore '(&rest vars))
+ (ignorable '(&rest vars))
+ (special '(&rest vars))
+ (inline '(&rest function-names))
+ (notinline '(&rest function-name))
+ (optimize '(&any compilation-speed debug safety space speed))
+ (type '(type-specifier &rest args))
+ (ftype '(type-specifier &rest function-names))
+ (otherwise
+ (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
+ (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
+ '(&rest vars))
+ ((and (listp decl-identifier) (typespec-p (first decl-identifier)))
+ '(&rest vars))
+ (t :not-available)))))))
+
+(defgeneric type-specifier-arglist (typespec-operator)
+ (:documentation
+ "Return the argument list of the type specifier belonging to
+TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
+:NOT-AVAILABLE is returned.
+
+The different SWANK backends can specialize this generic function to
+include implementation-dependend declaration specifiers, or to provide
+additional information on the specifiers defined in ANSI Common Lisp.")
+ (:method (typespec-operator)
+ (declare (special *type-specifier-arglists*)) ; defined at end of file.
+ (typecase typespec-operator
+ (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
+ :not-available))
+ (t :not-available))))
+
+(definterface function-name (function)
+ "Return the name of the function object FUNCTION.
+
+The result is either a symbol, a list, or NIL if no function name is available."
+ (declare (ignore function))
+ nil)
+
+(definterface macroexpand-all (form)
+ "Recursively expand all macros in FORM.
+Return the resulting form.")
+
+(definterface compiler-macroexpand-1 (form &optional env)
+ "Call the compiler-macro for form.
+If FORM is a function call for which a compiler-macro has been
+defined, invoke the expander function using *macroexpand-hook* and
+return the results and T. Otherwise, return the original form and
+NIL."
+ (let ((fun (and (consp form) (compiler-macro-function (car form)))))
+ (if fun
+ (let ((result (funcall *macroexpand-hook* fun form env)))
+ (values result (not (eq result form))))
+ (values form nil))))
+
+(definterface compiler-macroexpand (form &optional env)
+ "Repetitively call `compiler-macroexpand-1'."
+ (labels ((frob (form expanded)
+ (multiple-value-bind (new-form newly-expanded)
+ (compiler-macroexpand-1 form env)
+ (if newly-expanded
+ (frob new-form t)
+ (values new-form expanded)))))
+ (frob form env)))
+
+(definterface describe-symbol-for-emacs (symbol)
+ "Return a property list describing SYMBOL.
+
+The property list has an entry for each interesting aspect of the
+symbol. The recognised keys are:
+
+ :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
+ :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
+
+The value of each property is the corresponding documentation string,
+or :NOT-DOCUMENTED. It is legal to include keys not listed here (but
+slime-print-apropos in Emacs must know about them).
+
+Properties should be included if and only if they are applicable to
+the symbol. For example, only (and all) fbound symbols should include
+the :FUNCTION property.
+
+Example:
+\(describe-symbol-for-emacs 'vector)
+ => (:CLASS :NOT-DOCUMENTED
+ :TYPE :NOT-DOCUMENTED
+ :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
+
+(definterface install-debugger-globally (function)
+ "Install FUNCTION as the debugger for all threads/processes. This
+usually involves setting *DEBUGGER-HOOK* and, if the implementation
+permits, hooking into BREAK as well."
+ (setq *debugger-hook* function))
+
+(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
+debugger loop. The purpose is to setup any necessary environment for
+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.")
+
+(definterface call-with-debugger-hook (hook fun)
+ "Call FUN and use HOOK as debugger hook.
+
+HOOK should be called for both BREAK and INVOKE-DEBUGGER."
+ (let ((*debugger-hook* hook))
+ (funcall fun)))
+
+(define-condition sldb-condition (condition)
+ ((original-condition
+ :initarg :original-condition
+ :accessor original-condition))
+ (:report (lambda (condition stream)
+ (format stream "Condition in debugger code~@[: ~A~]"
+ (original-condition condition))))
+ (:documentation
+ "Wrapper for conditions that should not be debugged.
+
+When a condition arises from the internals of the debugger, it is not
+desirable to debug it -- we'd risk entering an endless loop trying to
+debug the debugger! Instead, such conditions can be reported to the
+user without (re)entering the debugger by wrapping them as
+`sldb-condition's."))
+
+(definterface compute-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 CALL-WITH-DEBUGGING-ENVIRONMENT.
+
+START and END are zero-based indices constraining the number of frames
+returned. Frame zero is defined as the frame which invoked the
+debugger. If END is nil, return the frames from START to the end of
+the stack.")
+
+(definterface compute-sane-restarts (condition)
+ "This is an opportunity for Lisps such as CLISP to remove
+unwanted restarts from the output of CL:COMPUTE-RESTARTS,
+otherwise it should simply call CL:COMPUTE-RESTARTS, which is
+what the default implementation does."
+ (compute-restarts condition))
+
+(definterface print-frame (frame stream)
+ "Print frame to stream.")
+
+(definterface frame-source-location-for-emacs (frame-number)
+ "Return the source location for FRAME-NUMBER.")
+
+(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.")
+
+(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.")
+
+(definterface frame-var-value (frame var)
+ "Return the value of VAR in FRAME.
+FRAME is the number of the frame in the backtrace.
+VAR is the number of the variable in the frame.")
+
+(definterface disassemble-frame (frame-number)
+ "Disassemble the code for the FRAME-NUMBER.
+The output should be written to standard output.
+FRAME-NUMBER is a non-negative integer.")
+
+(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.
+
+FRAME-NUMBER must be a positive integer with 0 indicating the
+frame which invoked the debugger.
+
+The return value is the result of evaulating FORM in the
+appropriate context.")
+
+(definterface return-from-frame (frame-number form)
+ "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
+produced by evaluating FORM in the frame context to its caller.
+
+Execute any clean-up code from unwind-protect forms above the frame
+during unwinding.
+
+Return a string describing the error if it's not possible to return
+from the frame.")
+
+(definterface restart-frame (frame-number)
+ "Restart execution of the frame FRAME-NUMBER with the same arguments
+as it was called originally.")
+
+(definterface format-sldb-condition (condition)
+ "Format a condition for display in SLDB."
+ (princ-to-string condition))
+
+(definterface condition-extras (condition)
+ "Return a list of extra for the debugger.
+The allowed elements are of the form:
+ (:SHOW-FRAME-SOURCE frame-number)
+ (:REFERENCES &rest refs)
+"
+ (declare (ignore condition))
+ '())
+
+(definterface activate-stepping (frame-number)
+ "Prepare the frame FRAME-NUMBER for stepping.")
+
+(definterface sldb-break-on-return (frame-number)
+ "Set a breakpoint in the frame FRAME-NUMBER.")
+
+(definterface sldb-break-at-start (symbol)
+ "Set a breakpoint on the beginning of the function for SYMBOL.")
+
+(definterface sldb-stepper-condition-p (condition)
+ "Return true if SLDB was invoked due to a single-stepping condition,
+false otherwise. "
+ (declare (ignore condition))
+ nil)
+
+(definterface sldb-step-into ()
+ "Step into the current single-stepper form.")
+
+(definterface sldb-step-next ()
+ "Step to the next form in the current function.")
+
+(definterface sldb-step-out ()
+ "Stop single-stepping temporarily, but resume it once the current function
+returns.")
+
+
+;;;; Definition finding
+
+(defstruct (:location (:type list) :named
+ (:constructor make-location
+ (buffer position &optional hints)))
+ buffer position
+ ;; Hints is a property list optionally containing:
+ ;; :snippet SOURCE-TEXT
+ ;; This is a snippet of the actual source text at the start of
+ ;; the definition, which could be used in a text search.
+ hints)
+
+(defstruct (:error (:type list) :named (:constructor)) message)
+(defstruct (:file (:type list) :named (:constructor)) name)
+(defstruct (:buffer (:type list) :named (:constructor)) name)
+(defstruct (:position (:type list) :named (:constructor)) pos)
+
+(definterface find-definitions (name)
+ "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
+
+NAME is a \"definition specifier\".
+
+DSPEC is a \"definition specifier\" describing the
+definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
+\(DEFVAR FOO).
+
+LOCATION is the source location for the definition.")
+
+(definterface buffer-first-change (filename)
+ "Called for effect the first time FILENAME's buffer is modified."
+ (declare (ignore filename))
+ nil)
+
+
+;;;; XREF
+
+(definterface who-calls (function-name)
+ "Return the call sites of FUNCTION-NAME (a symbol).
+The results is a list ((DSPEC LOCATION) ...).")
+
+(definterface calls-who (function-name)
+ "Return the call sites of FUNCTION-NAME (a symbol).
+The results is a list ((DSPEC LOCATION) ...).")
+
+(definterface who-references (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is referenced.
+See WHO-CALLS for a description of the return value.")
+
+(definterface who-binds (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is bound.
+See WHO-CALLS for a description of the return value.")
+
+(definterface who-sets (variable-name)
+ "Return the locations where VARIABLE-NAME (a symbol) is set.
+See WHO-CALLS for a description of the return value.")
+
+(definterface who-macroexpands (macro-name)
+ "Return the locations where MACRO-NAME (a symbol) is expanded.
+See WHO-CALLS for a description of the return value.")
+
+(definterface who-specializes (class-name)
+ "Return the locations where CLASS-NAME (a symbol) is specialized.
+See WHO-CALLS for a description of the return value.")
+
+;;; Simpler variants.
+
+(definterface list-callers (function-name)
+ "List the callers of FUNCTION-NAME.
+This function is like WHO-CALLS except that it is expected to use
+lower-level means. Whereas WHO-CALLS is usually implemented with
+special compiler support, LIST-CALLERS is usually implemented by
+groveling for constants in function objects throughout the heap.
+
+The return value is as for WHO-CALLS.")
+
+(definterface list-callees (function-name)
+ "List the functions called by FUNCTION-NAME.
+See LIST-CALLERS for a description of the return value.")
+
+
+;;;; Profiling
+
+;;; The following functions define a minimal profiling interface.
+
+(definterface profile (fname)
+ "Marks symbol FNAME for profiling.")
+
+(definterface profiled-functions ()
+ "Returns a list of profiled functions.")
+
+(definterface unprofile (fname)
+ "Marks symbol FNAME as not profiled.")
+
+(definterface unprofile-all ()
+ "Marks all currently profiled functions as not profiled."
+ (dolist (f (profiled-functions))
+ (unprofile f)))
+
+(definterface profile-report ()
+ "Prints profile report.")
+
+(definterface profile-reset ()
+ "Resets profile counters.")
+
+(definterface profile-package (package callers-p methods)
+ "Wrap profiling code around all functions in PACKAGE. If a function
+is already profiled, then unprofile and reprofile (useful to notice
+function redefinition.)
+
+If CALLERS-P is T names have counts of the most common calling
+functions recorded.
+
+When called with arguments :METHODS T, profile all methods of all
+generic functions having names in the given package. Generic functions
+themselves, that is, their dispatch functions, are left alone.")
+
+
+;;;; Inspector
+
+(defclass inspector ()
+ ()
+ (:documentation "Super class of inspector objects.
+
+Implementations should sub class in order to dispatch off of the
+inspect-for-emacs method."))
+
+(defclass backend-inspector (inspector) ())
+
+(definterface make-default-inspector ()
+ "Return an inspector object suitable for passing to inspect-for-emacs.")
+
+(defgeneric inspect-for-emacs (object inspector)
+ (:documentation
+ "Explain to Emacs how to inspect OBJECT.
+
+The argument INSPECTOR is an object representing how to get at
+the internals of OBJECT, it is usually an implementation specific
+class used simply for dispatching to the proper method.
+
+Returns two values: a string which will be used as the title of
+the inspector buffer and a list specifying how to render the
+object for inspection.
+
+Every element of the list must be either a string, which will be
+inserted into the buffer as is, or a list of the form:
+
+ (:value object &optional format) - Render an inspectable
+ object. If format is provided it must be a string and will be
+ rendered in place of the value, otherwise use princ-to-string.
+
+ (:newline) - Render a \\n
+
+ (:action label lambda &key (refresh t)) - Render LABEL (a text
+ string) which when clicked will call LAMBDA. If REFRESH is
+ non-NIL the currently inspected object will be re-inspected
+ after calling the lambda.
+
+ NIL - do nothing."))
+
+(defmethod inspect-for-emacs ((object t) (inspector t))
+ "Generic method for inspecting any kind of object.
+
+Since we don't know how to deal with OBJECT we simply dump the
+output of CL:DESCRIBE."
+ (declare (ignore inspector))
+ (values
+ "A value."
+ `("Type: " (:value ,(type-of object)) (:newline)
+ "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
+ (:newline) (:newline)
+ ,(with-output-to-string (desc) (describe object desc)))))
+
+;;; Utilities for inspector methods.
+;;;
+(defun label-value-line (label value &key (newline t))
+ "Create a control list which prints \"LABEL: VALUE\" in the inspector.
+If NEWLINE is non-NIL a `(:newline)' is added to the result."
+ (list* (princ-to-string label) ": " `(:value ,value)
+ (if newline '((:newline)) nil)))
+
+(defmacro label-value-line* (&rest label-values)
+ ` (append ,@(loop for (label value) in label-values
+ collect `(label-value-line ,label ,value))))
+
+(definterface describe-primitive-type (object)
+ "Return a string describing the primitive type of object."
+ (declare (ignore object))
+ "N/A")
+
+
+;;;; Multithreading
+;;;
+;;; The default implementations are sufficient for non-multiprocessing
+;;; implementations.
+
+(definterface initialize-multiprocessing (continuation)
+ "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
+
+Depending on the impleimentaion, this function may never return."
+ (funcall continuation))
+
+(definterface spawn (fn &key name)
+ "Create a new thread to call FN.")
+
+(definterface thread-id (thread)
+ "Return an Emacs-parsable object to identify THREAD.
+
+Ids should be comparable with equal, i.e.:
+ (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)")
+
+(definterface find-thread (id)
+ "Return the thread for ID.
+ID should be an id previously obtained with THREAD-ID.
+Can return nil if the thread no longer exists.")
+
+(definterface thread-name (thread)
+ "Return the name of THREAD.
+
+Thread names are be single-line strings and are meaningful to the
+user. They do not have to be unique."
+ (declare (ignore thread))
+ "The One True Thread")
+
+(definterface thread-status (thread)
+ "Return a string describing THREAD's state."
+ (declare (ignore thread))
+ "")
+
+(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."
+ (declare (ignore name))
+ :null-lock)
+
+(definterface call-with-lock-held (lock function)
+ "Call FUNCTION with LOCK held, queueing if necessary."
+ (declare (ignore lock)
+ (type function function))
+ (funcall function))
+
+(definterface make-recursive-lock (&key name)
+ "Make a lock for thread synchronization.
+Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
+at a time, but that thread may hold it more than once."
+ (cons nil (make-lock :name name)))
+
+(definterface call-with-recursive-lock-held (lock function)
+ "Call FUNCTION with LOCK held, queueing if necessary."
+ (if (eql (car lock) (current-thread))
+ (funcall function)
+ (call-with-lock-held (cdr lock)
+ (lambda ()
+ (unwind-protect
+ (progn
+ (setf (car lock) (current-thread))
+ (funcall function))
+ (setf (car lock) nil))))))
+
+(definterface current-thread ()
+ "Return the currently executing thread."
+ 0)
+
+(definterface all-threads ()
+ "Return a list of all threads.")
+
+(definterface thread-alive-p (thread)
+ "Test if THREAD is termintated."
+ (member thread (all-threads)))
+
+(definterface interrupt-thread (thread fn)
+ "Cause THREAD to execute FN.")
+
+(definterface kill-thread (thread)
+ "Kill THREAD."
+ (declare (ignore thread))
+ nil)
+
+(definterface send (thread object)
+ "Send OBJECT to thread THREAD.")
+
+(definterface receive ()
+ "Return the next message from current thread's mailbox.")
+
+(definterface toggle-trace (spec)
+ "Toggle tracing of the function(s) given with SPEC.
+SPEC can be:
+ (setf NAME) ; a setf function
+ (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
+ (:defgeneric NAME) ; a generic function with all methods
+ (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
+ (:labels TOPLEVEL LOCAL)
+ (:flet TOPLEVEL LOCAL) ")
+
+
+;;;; Weak datastructures
+
+(definterface make-weak-key-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
+ (apply #'make-hash-table args))
+
+(definterface make-weak-value-hash-table (&rest args)
+ "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
+ (apply #'make-hash-table args))
+
+(definterface hash-table-weakness (hashtable)
+ "Return nil or one of :key :value :key-or-value :key-and-value"
+ (declare (ignore hashtable))
+ nil)
+
+
+;;;; Character names
+
+(definterface character-completion-set (prefix matchp)
+ "Return a list of names of characters that match PREFIX."
+ ;; Handle the standard and semi-standard characters.
+ (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
+ "Linefeed" "Return" "Backspace")
+ when (funcall matchp prefix name)
+ collect name))
+
+
+(defparameter *type-specifier-arglists*
+ '((and . (&rest type-specifiers))
+ (array . (&optional element-type dimension-spec))
+ (base-string . (&optional size))
+ (bit-vector . (&optional size))
+ (complex . (&optional type-specifier))
+ (cons . (&optional car-typespec cdr-typespec))
+ (double-float . (&optional lower-limit upper-limit))
+ (eql . (object))
+ (float . (&optional lower-limit upper-limit))
+ (function . (&optional arg-typespec value-typespec))
+ (integer . (&optional lower-limit upper-limit))
+ (long-float . (&optional lower-limit upper-limit))
+ (member . (&rest eql-objects))
+ (mod . (n))
+ (not . (type-specifier))
+ (or . (&rest type-specifiers))
+ (rational . (&optional lower-limit upper-limit))
+ (real . (&optional lower-limit upper-limit))
+ (satisfies . (predicate-symbol))
+ (short-float . (&optional lower-limit upper-limit))
+ (signed-byte . (&optional size))
+ (simple-array . (&optional element-type dimension-spec))
+ (simple-base-string . (&optional size))
+ (simple-bit-vector . (&optional size))
+ (simple-string . (&optional size))
+ (single-float . (&optional lower-limit upper-limit))
+ (simple-vector . (&optional size))
+ (string . (&optional size))
+ (unsigned-byte . (&optional size))
+ (values . (&rest typespecs))
+ (vector . (&optional element-type size))
+ ))
Added: branches/bos/thirdparty/emacs/slime/swank-clisp.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-clisp.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,672 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+;;;; SWANK support for CLISP.
+
+;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
+
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation; either version 2 of
+;;;; the License, or (at your option) any later version.
+
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with this program; if not, write to the Free
+;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;;;; MA 02111-1307, USA.
+
+;;; This is work in progress, but it's already usable. Many things
+;;; are adapted from other swank-*.lisp, in particular from
+;;; swank-allegro (I don't use allegro at all, but it's the shortest
+;;; one and I found Helmut Eller's code there enlightening).
+
+;;; This code will work better with recent versions of CLISP (say, the
+;;; last release or CVS HEAD) while it may not work at all with older
+;;; versions. It is reasonable to expect it to work on platforms with
+;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
+;;; systems, but also on Win32. This backend uses the portable xref
+;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
+;;; are conveniently included in SLIME.
+
+;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
+
+(in-package :swank-backend)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;(use-package "SOCKET")
+ (use-package "GRAY"))
+
+;;;; if this lisp has the complete CLOS then we use it, otherwise we
+;;;; build up a "fake" swank-mop and then override the methods in the
+;;;; inspector.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *have-mop*
+ (and (find-package :clos)
+ (eql :external
+ (nth-value 1 (find-symbol (string ':standard-slot-definition)
+ :clos))))
+ "True in those CLISP images which have a complete MOP implementation."))
+
+#+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
+(progn
+ (import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+ (defun swank-mop:slot-definition-documentation (slot)
+ (clos::slot-definition-documentation slot)))
+
+#-#.(cl:if swank-backend::*have-mop* '(and) '(or))
+(defclass swank-mop:standard-slot-definition ()
+ ()
+ (:documentation
+ "Dummy class created so that swank.lisp will compile and load."))
+
+;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
+;; (progn
+;; (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 ,@body)
+;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
+
+;; (defimplementation call-without-interrupts (fn)
+;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
+
+;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and))
+(defimplementation call-without-interrupts (fn)
+ (funcall fn))
+
+(let ((getpid (or (find-symbol "PROCESS-ID" :system)
+ ;; old name prior to 2005-03-01, clisp <= 2.33.2
+ (find-symbol "PROGRAM-ID" :system)
+ #+win32 ; integrated into the above since 2005-02-24
+ (and (find-package :win32) ; optional modules/win32
+ (find-symbol "GetCurrentProcessId" :win32)))))
+ (defimplementation getpid () ; a required interface
+ (cond
+ (getpid (funcall getpid))
+ #+win32 ((ext:getenv "PID")) ; where does that come from?
+ (t -1))))
+
+(defimplementation lisp-implementation-type-name ()
+ "clisp")
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) directory)
+ (namestring (setf *default-pathname-defaults* (ext:default-directory))))
+
+;;;; TCP Server
+
+(defimplementation create-socket (host port)
+ (declare (ignore host))
+ (socket:socket-server port))
+
+(defimplementation local-port (socket)
+ (socket:socket-server-port socket))
+
+(defimplementation close-socket (socket)
+ (socket:socket-server-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout))
+ (socket:socket-accept socket
+ :buffered nil ;; XXX should be t
+ :element-type 'character
+ :external-format external-format))
+
+;;;; Coding systems
+
+(defvar *external-format-to-coding-system*
+ '(((:charset "iso-8859-1" :line-terminator :unix)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ ((:charset "iso-8859-1":latin-1)
+ "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:charset "utf-8") "utf-8")
+ ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
+ ((:charset "euc-jp") "euc-jp")
+ ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
+ ((:charset "us-ascii") "us-ascii")
+ ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (let ((args (car (rassoc-if (lambda (x)
+ (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))))
+ (and args (apply #'ext:make-encoding args))))
+
+
+;;;; Swank functions
+
+(defimplementation arglist (fname)
+ (block nil
+ (or (ignore-errors
+ (let ((exp (function-lambda-expression fname)))
+ (and exp (return (second exp)))))
+ (ignore-errors
+ (return (ext:arglist fname)))
+ :not-available)))
+
+(defimplementation macroexpand-all (form)
+ (ext:expand-form form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ "Return a plist describing SYMBOL.
+Return NIL if the symbol is unbound."
+ (let ((result ()))
+ (flet ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push :variable (when (boundp symbol) (doc 'variable)))
+ (when (fboundp symbol)
+ (maybe-push
+ ;; Report WHEN etc. as macros, even though they may be
+ ;; implemented as special operators.
+ (if (macro-function symbol) :macro
+ (typecase (fdefinition symbol)
+ (generic-function :generic-function)
+ (function :function)
+ ;; (type-of 'progn) -> ext:special-operator
+ (t :special-operator)))
+ (doc 'function)))
+ (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
+ (get symbol 'system::setf-expander)); defsetf
+ (maybe-push :setf (doc 'setf)))
+ (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
+ (get symbol 'system::defstruct-description)
+ (get symbol 'system::deftype-expander))
+ (maybe-push :type (doc 'type))) ; even for 'structure
+ (when (find-class symbol nil)
+ (maybe-push :class (doc 'type)))
+ ;; Let this code work compiled in images without FFI
+ (let ((types (load-time-value
+ (and (find-package "FFI")
+ (symbol-value
+ (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
+ ;; Use ffi::*c-type-table* so as not to suffer the overhead of
+ ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
+ ;; which are not FFI type names.
+ (when (and types (nth-value 1 (gethash symbol types)))
+ ;; Maybe use (case (head (ffi:deparse-c-type)))
+ ;; to distinguish struct and union types?
+ (maybe-push :alien-type :not-documented)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable (describe symbol))
+ (:macro (describe (macro-function symbol)))
+ (:function (describe (symbol-function symbol)))
+ (:class (describe (find-class symbol)))))
+
+(defun fspec-pathname (symbol)
+ (let ((path (documentation symbol 'sys::file))
+ lines)
+ (when (consp path)
+ (psetq path (car path)
+ lines (cdr path)))
+ (when (and path
+ (member (pathname-type path)
+ custom:*compiled-file-types* :test #'equal))
+ (setq path
+ (loop for suffix in custom:*source-file-types*
+ thereis (probe-file (make-pathname :defaults path
+ :type suffix)))))
+ (values path lines)))
+
+(defun fspec-location (fspec)
+ (multiple-value-bind (file lines)
+ (fspec-pathname fspec)
+ (cond (file
+ (multiple-value-bind (truename c) (ignore-errors (truename file))
+ (cond (truename
+ (make-location (list :file (namestring truename))
+ (if (consp lines)
+ (list* :line lines)
+ (list :function-name (string fspec)))))
+ (t (list :error (princ-to-string c))))))
+ (t (list :error (format nil "No source information available for: ~S"
+ fspec))))))
+
+(defimplementation find-definitions (name)
+ (list (list name (fspec-location name))))
+
+(defun trim-whitespace (string)
+ (string-trim #(#\newline #\space #\tab) string))
+
+(defvar *sldb-backtrace*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* (;;(sys::*break-count* (1+ sys::*break-count*))
+ ;;(sys::*driver* debugger-loop-fn)
+ ;;(sys::*fasoutput-stream* nil)
+ (*sldb-backtrace*
+ (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
+ (funcall debugger-loop-fn)))
+
+(defun nth-frame (index)
+ (nth index *sldb-backtrace*))
+
+(defun sldb-backtrace ()
+ "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
+ (do ((frames '())
+ (last nil frame)
+ (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames"
+ ((eq frame last) (nreverse frames))
+ (unless (boring-frame-p frame)
+ (push frame frames))))
+
+(defun boring-frame-p (frame)
+ (member (frame-type frame) '(stack-value bind-var bind-env)))
+
+(defun frame-to-string (frame)
+ (with-output-to-string (s)
+ (sys::describe-frame s frame)))
+
+(defun frame-type (frame)
+ ;; FIXME: should bind *print-length* etc. to small values.
+ (frame-string-type (frame-to-string frame)))
+
+(defvar *frame-prefixes*
+ '(("frame binding variables" bind-var)
+ ("<1> #<compiled-function" compiled-fun)
+ ("<1> #<system-function" sys-fun)
+ ("<1> #<special-operator" special-op)
+ ("EVAL frame" eval)
+ ("APPLY frame" apply)
+ ("compiled tagbody frame" compiled-tagbody)
+ ("compiled block frame" compiled-block)
+ ("block frame" block)
+ ("nested block frame" block)
+ ("tagbody frame" tagbody)
+ ("nested tagbody frame" tagbody)
+ ("catch frame" catch)
+ ("handler frame" handler)
+ ("unwind-protect frame" unwind-protect)
+ ("driver frame" driver)
+ ("frame binding environments" bind-env)
+ ("CALLBACK frame" callback)
+ ("- " stack-value)
+ ("<1> " fun)
+ ("<2> " 2nd-frame)))
+
+(defun frame-string-type (string)
+ (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
+ *frame-prefixes*)))
+
+(defimplementation compute-backtrace (start end)
+ (let* ((bt *sldb-backtrace*)
+ (len (length bt)))
+ (subseq bt start (min (or end len) len))))
+
+;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we
+;;; can omit that restart so that users don't select it by mistake.
+(defimplementation compute-sane-restarts (condition)
+ ;; The outermost restart is specified to be the last element of the
+ ;; list, hopefully that's our unwanted ABORT restart.
+ (butlast (compute-restarts condition)))
+
+(defimplementation print-frame (frame stream)
+ (let ((str (frame-to-string frame)))
+ ;; (format stream "~A " (frame-string-type str))
+ (write-string (extract-frame-line str)
+ stream)))
+
+(defun extract-frame-line (frame-string)
+ (let ((s frame-string))
+ (trim-whitespace
+ (case (frame-string-type s)
+ ((eval special-op)
+ (string-match "EVAL frame .*for form \\(.*\\)" s 1))
+ (apply
+ (string-match "APPLY frame for call \\(.*\\)" s 1))
+ ((compiled-fun sys-fun fun)
+ (extract-function-name s))
+ (t s)))))
+
+(defun extract-function-name (string)
+ (let ((1st (car (split-frame-string string))))
+ (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
+ 1st
+ 1)
+ (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
+ 1st)))
+
+(defun split-frame-string (string)
+ (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
+ (mapcar #'car *frame-prefixes*))))
+ (loop for pos = 0 then (1+ (regexp:match-start match))
+ for match = (regexp:match rx string :start pos)
+ if match collect (subseq string pos (regexp:match-start match))
+ else collect (subseq string pos)
+ while match)))
+
+(defun string-match (pattern string n)
+ (let* ((match (nth-value n (regexp:match pattern string))))
+ (if match (regexp:match-string string match))))
+
+(defimplementation format-sldb-condition (condition)
+ (trim-whitespace (princ-to-string condition)))
+
+(defimplementation eval-in-frame (form frame-number)
+ (sys::eval-at (nth-frame frame-number) form))
+
+(defimplementation frame-locals (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (loop for i below (%frame-count-vars frame)
+ collect (list :name (%frame-var-name frame i)
+ :value (%frame-var-value frame i)
+ :id 0))))
+
+(defimplementation frame-var-value (frame var)
+ (%frame-var-value (nth-frame frame) var))
+
+;;; Interpreter-Variablen-Environment has the shape
+;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
+
+(defun %frame-count-vars (frame)
+ (cond ((sys::eval-frame-p frame)
+ (do ((venv (frame-venv frame) (next-venv venv))
+ (count 0 (+ count (/ (1- (length venv)) 2))))
+ ((not venv) count)))
+ ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
+ (length (%parse-stack-values frame)))
+ (t 0)))
+
+(defun %frame-var-name (frame i)
+ (cond ((sys::eval-frame-p frame)
+ (nth-value 0 (venv-ref (frame-venv frame) i)))
+ (t (format nil "~D" i))))
+
+(defun %frame-var-value (frame i)
+ (cond ((sys::eval-frame-p frame)
+ (let ((name (venv-ref (frame-venv frame) i)))
+ (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
+ (if c
+ (format-sldb-condition c)
+ v))))
+ ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
+ (let ((str (nth i (%parse-stack-values frame))))
+ (trim-whitespace (subseq str 2))))
+ (t (break "Not implemented"))))
+
+(defun frame-venv (frame)
+ (let ((env (sys::eval-at frame '(sys::the-environment))))
+ (svref env 0)))
+
+(defun next-venv (venv) (svref venv (1- (length venv))))
+
+(defun venv-ref (env i)
+ "Reference the Ith binding in ENV.
+Return two values: NAME and VALUE"
+ (let ((idx (* i 2)))
+ (if (< idx (1- (length env)))
+ (values (svref env idx) (svref env (1+ idx)))
+ (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
+
+(defun %parse-stack-values (frame)
+ (labels ((next (fp) (sys::frame-down-1 fp 1))
+ (parse (fp accu)
+ (let ((str (frame-to-string fp)))
+ (cond ((is-prefix-p "- " str)
+ (parse (next fp) (cons str accu)))
+ ((is-prefix-p "<1> " str)
+ ;;(when (eq (frame-type frame) 'compiled-fun)
+ ;; (pop accu))
+ (dolist (str (cdr (split-frame-string str)))
+ (when (is-prefix-p "- " str)
+ (push str accu)))
+ (nreverse accu))
+ (t (parse (next fp) accu))))))
+ (parse (next frame) '())))
+
+(defun is-prefix-p (pattern string)
+ (not (mismatch pattern string :end2 (min (length pattern)
+ (length string)))))
+
+(defimplementation frame-catch-tags (index)
+ (declare (ignore index))
+ nil)
+
+(defimplementation return-from-frame (index form)
+ (sys::return-from-eval-frame (nth-frame index) form))
+
+(defimplementation restart-frame (index)
+ (sys::redo-eval-frame (nth-frame index)))
+
+(defimplementation frame-source-location-for-emacs (index)
+ `(:error
+ ,(format nil "frame-source-location not implemented. (frame: ~A)"
+ (nth-frame index))))
+
+;;;; Profiling
+
+(defimplementation profile (fname)
+ (eval `(mon:monitor ,fname))) ;monitor is a macro
+
+(defimplementation profiled-functions ()
+ mon:*monitored-functions*)
+
+(defimplementation unprofile (fname)
+ (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
+
+(defimplementation unprofile-all ()
+ (mon:unmonitor))
+
+(defimplementation profile-report ()
+ (mon:report-monitoring))
+
+(defimplementation profile-reset ()
+ (mon:reset-all-monitoring))
+
+(defimplementation profile-package (package callers-p methods)
+ (declare (ignore callers-p methods))
+ (mon:monitor-all package))
+
+;;;; Handle compiler conditions (find out location of error etc.)
+
+(defmacro compile-file-frobbing-notes ((&rest args) &body body)
+ "Pass ARGS to COMPILE-FILE, send the compiler notes to
+*STANDARD-INPUT* and frob them in BODY."
+ `(let ((*error-output* (make-string-output-stream))
+ (*compile-verbose* t))
+ (multiple-value-prog1
+ (compile-file ,@args)
+ (handler-case
+ (with-input-from-string
+ (*standard-input* (get-output-stream-string *error-output*))
+ ,@body)
+ (sys::simple-end-of-file () nil)))))
+
+(defvar *orig-c-warn* (symbol-function 'system::c-warn))
+(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
+(defvar *orig-c-error* (symbol-function 'system::c-error))
+(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
+
+(defmacro dynamic-flet (names-functions &body body)
+ "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
+Execute BODY with NAME's function slot set to FUNCTION."
+ `(ext:letf* ,(loop for (name function) in names-functions
+ collect `((symbol-function ',name) ,function))
+ ,@body))
+
+(defvar *buffer-name* nil)
+(defvar *buffer-offset*)
+
+(defun compiler-note-location ()
+ "Return the current compiler location."
+ (let ((lineno1 sys::*compile-file-lineno1*)
+ (lineno2 sys::*compile-file-lineno2*)
+ (file sys::*compile-file-truename*))
+ (cond ((and file lineno1 lineno2)
+ (make-location (list ':file (namestring file))
+ (list ':line lineno1)))
+ (*buffer-name*
+ (make-location (list ':buffer *buffer-name*)
+ (list ':position *buffer-offset*)))
+ (t
+ (list :error "No error location available")))))
+
+(defun signal-compiler-warning (cstring args severity orig-fn)
+ (signal (make-condition 'compiler-condition
+ :severity severity
+ :message (apply #'format nil cstring args)
+ :location (compiler-note-location)))
+ (apply orig-fn cstring args))
+
+(defun c-warn (cstring &rest args)
+ (signal-compiler-warning cstring args :warning *orig-c-warn*))
+
+(defun c-style-warn (cstring &rest args)
+ (dynamic-flet ((sys::c-warn *orig-c-warn*))
+ (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
+
+(defun c-error (cstring &rest args)
+ (signal-compiler-warning cstring args :error *orig-c-error*))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((warning #'handle-notification-condition))
+ (dynamic-flet ((system::c-warn #'c-warn)
+ (system::c-style-warn #'c-style-warn)
+ (system::c-error #'c-error))
+ (funcall function))))
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (signal (make-condition 'compiler-condition
+ :original-condition condition
+ :severity :warning
+ :message (princ-to-string condition)
+ :location (compiler-note-location))))
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (with-compilation-hooks ()
+ (with-compilation-unit ()
+ (let ((fasl-file (compile-file filename
+ :external-format external-format)))
+ (when (and load-p fasl-file)
+ (load fasl-file))
+ nil))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-offset* position))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string)))))))
+
+;;;; Portable XREF from the CMU AI repository.
+
+(setq pxref::*handle-package-forms* '(cl:in-package))
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls pxref:list-callers)
+(defxref who-references pxref:list-readers)
+(defxref who-binds pxref:list-setters)
+(defxref who-sets pxref:list-setters)
+(defxref list-callers pxref:list-callers)
+(defxref list-callees pxref:list-callees)
+
+(defun xref-results (symbols)
+ (let ((xrefs '()))
+ (dolist (symbol symbols)
+ (push (list symbol (fspec-location symbol)) xrefs))
+ xrefs))
+
+(when (find-package :swank-loader)
+ (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
+ (lambda ()
+ (let ((home (user-homedir-pathname)))
+ (and (ext:probe-directory home)
+ (probe-file (format nil "~A/.swank.lisp"
+ (namestring (truename home)))))))))
+
+;;; Don't set *debugger-hook* to nil on break.
+(ext:without-package-lock ()
+ (defun break (&optional (format-string "Break") &rest args)
+ (if (not sys::*use-clcs*)
+ (progn
+ (terpri *error-output*)
+ (apply #'format *error-output*
+ (concatenate 'string "*** - " format-string)
+ args)
+ (funcall ext:*break-driver* t))
+ (let ((condition
+ (make-condition 'simple-condition
+ :format-control format-string
+ :format-arguments args))
+ ;;(*debugger-hook* nil)
+ ;; Issue 91
+ )
+ (ext:with-restarts
+ ((continue
+ :report (lambda (stream)
+ (format stream (sys::text "Return from ~S loop")
+ 'break))
+ ()))
+ (with-condition-restarts condition (list (find-restart 'continue))
+ (invoke-debugger condition)))))
+ nil))
+
+;;;; Inspecting
+
+(defclass clisp-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector () (make-instance 'clisp-inspector))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (let* ((*print-array* nil) (*print-pretty* t)
+ (*print-circle* t) (*print-escape* t)
+ (*print-lines* custom:*inspect-print-lines*)
+ (*print-level* custom:*inspect-print-level*)
+ (*print-length* custom:*inspect-print-length*)
+ (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
+ (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
+ (*package* tmp-pack)
+ (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
+ (let ((inspection (sys::inspect-backend o)))
+ (values (format nil "~S~% ~A~{~%~A~}" o
+ (sys::insp-title inspection)
+ (sys::insp-blurb inspection))
+ (loop with count = (sys::insp-num-slots inspection)
+ for i below count
+ append (multiple-value-bind (value name)
+ (funcall (sys::insp-nth-slot inspection)
+ i)
+ `((:value ,name) " = " (:value ,value)
+ (:newline))))))))
+
+(defimplementation quit-lisp ()
+ #+lisp=cl (ext:quit)
+ #-lisp=cl (lisp:quit))
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :weak :value args))
+
+;;; Local Variables:
+;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
+;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
+;;; End:
Added: branches/bos/thirdparty/emacs/slime/swank-cmucl.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-cmucl.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,2256 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
+;;;
+;;; License: Public Domain
+;;;
+;;;; Introduction
+;;;
+;;; This is the CMUCL implementation of the `swank-backend' package.
+
+(in-package :swank-backend)
+
+(import-swank-mop-symbols :pcl '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+;;;; "Hot fixes"
+;;;
+;;; Here are necessary bugfixes to the oldest supported version of
+;;; CMUCL (currently 18e). Any fixes placed here should also be
+;;; submitted to the `cmucl-imp' mailing list and confirmed as
+;;; good. When a new release is made that includes the fixes we should
+;;; promptly delete them from here. It is enough to be compatible with
+;;; the latest release.
+
+(in-package :lisp)
+
+;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new
+;;; definition works better.
+
+#-cmu19
+(progn
+ (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
+ (when s
+ (setf (symbol-value s) nil)))
+
+ (defun read-into-simple-string (s stream start end)
+ (declare (type simple-string s))
+ (declare (type stream stream))
+ (declare (type index start end))
+ (unless (subtypep (stream-element-type stream) 'character)
+ (error 'type-error
+ :datum (read-char stream nil #\Null)
+ :expected-type (stream-element-type stream)
+ :format-control "Trying to read characters from a binary stream."))
+ ;; Let's go as low level as it seems reasonable.
+ (let* ((numbytes (- end start))
+ (total-bytes 0))
+ ;; read-n-bytes may return fewer bytes than requested, so we need
+ ;; to keep trying.
+ (loop while (plusp numbytes) do
+ (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
+ (when (zerop bytes-read)
+ (return-from read-into-simple-string total-bytes))
+ (incf total-bytes bytes-read)
+ (incf start bytes-read)
+ (decf numbytes bytes-read)))
+ total-bytes))
+
+ (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
+ (when s
+ (setf (symbol-value s) t)))
+
+ )
+
+(in-package :swank-backend)
+
+
+;;;; TCP server
+;;;
+;;; In CMUCL we support all communication styles. By default we use
+;;; `:SIGIO' because it is the most responsive, but it's somewhat
+;;; dangerous: CMUCL is not in general "signal safe", and you don't
+;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
+;;; `:SPAWN' are reasonable alternatives.
+
+(defimplementation preferred-communication-style ()
+ :sigio)
+
+#-(or darwin mips)
+(defimplementation create-socket (host port)
+ (let* ((addr (resolve-hostname host))
+ (addr (if (not (find-symbol "SOCKET-ERROR" :ext))
+ (ext:htonl addr)
+ addr)))
+ (ext:create-inet-listener port :stream :reuse-address t :host addr)))
+
+;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix.
+#+(or darwin mips)
+(defimplementation create-socket (host port)
+ (declare (ignore host))
+ (ext:create-inet-listener port :stream :reuse-address t))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (let ((fd (socket-fd socket)))
+ (sys:invalidate-descriptor fd)
+ (ext:close-socket fd)))
+
+(defimplementation accept-connection (socket &key
+ external-format buffering timeout)
+ (declare (ignore timeout external-format))
+ (let ((buffering (or buffering :full)))
+ (make-socket-io-stream (ext:accept-tcp-connection socket) buffering)))
+
+;;;;; Sockets
+
+(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 (in host byte-order)."
+ (let ((hostent (ext:lookup-host-entry hostname)))
+ (car (ext:host-entry-addr-list hostent))))
+
+(defun make-socket-io-stream (fd buffering)
+ "Create a new input/output fd-stream for FD."
+ (sys:make-fd-stream fd :input t :output t :element-type 'base-char
+ :buffering buffering))
+
+;;;;; Signal-driven I/O
+
+(defvar *sigio-handlers* '()
+ "List of (key . function) pairs.
+All functions are called on SIGIO, and the key is used for removing
+specific functions.")
+
+(defun set-sigio-handler ()
+ (sys:enable-interrupt :sigio (lambda (signal code scp)
+ (sigio-handler signal code scp))))
+
+(defun sigio-handler (signal code scp)
+ (declare (ignore signal code scp))
+ (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
+
+(defun fcntl (fd command arg)
+ "fcntl(2) - manipulate a file descriptor."
+ (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
+ (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error)))))
+
+(defimplementation add-sigio-handler (socket fn)
+ (set-sigio-handler)
+ (let ((fd (socket-fd socket)))
+ (fcntl fd unix:f-setown (unix:unix-getpid))
+ (fcntl fd unix:f-setfl unix:fasync)
+ (push (cons fd fn) *sigio-handlers*)))
+
+(defimplementation remove-sigio-handlers (socket)
+ (let ((fd (socket-fd socket)))
+ (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
+ (sys:invalidate-descriptor fd)))
+
+;;;;; SERVE-EVENT
+
+(defimplementation add-fd-handler (socket fn)
+ (let ((fd (socket-fd socket)))
+ (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn)))))
+
+(defimplementation remove-fd-handlers (socket)
+ (sys:invalidate-descriptor (socket-fd socket)))
+
+
+;;;; Stream handling
+;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
+
+(defimplementation 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)))
+
+(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)
+ (:constructor make-slime-output-stream (output-fn)))
+ (output-fn nil :type function)
+ (buffer (make-string 8000) :type string)
+ (index 0 :type kernel:index)
+ (column 0 :type kernel:index)
+ (last-flush-time (get-internal-real-time) :type unsigned-byte))
+
+(defun %print-slime-output-stream (s stream d)
+ (declare (ignore d))
+ (print-unreadable-object (s stream :type t :identity t)))
+
+(defun sos/out (stream char)
+ (system:without-interrupts
+ (let ((buffer (sos.buffer stream))
+ (index (sos.index stream)))
+ (setf (schar buffer index) char)
+ (setf (sos.index stream) (1+ index))
+ (incf (sos.column stream))
+ (when (char= #\newline char)
+ (setf (sos.column stream) 0)
+ (force-output stream))
+ (when (= index (1- (length buffer)))
+ (finish-output stream)))
+ char))
+
+(defun sos/sout (stream string start end)
+ (system:without-interrupts
+ (loop for i from start below end
+ do (sos/out stream (aref string i)))))
+
+(defun log-stream-op (stream operation)
+ stream operation
+ #+(or)
+ (progn
+ (format sys:*tty* "~S @ ~D ~A~%" operation
+ (sos.index stream)
+ (/ (- (get-internal-real-time) (sos.last-flush-time stream))
+ (coerce internal-time-units-per-second 'double-float)))
+ (finish-output sys:*tty*)))
+
+(defun sos/misc (stream operation &optional arg1 arg2)
+ (declare (ignore arg1 arg2))
+ (case operation
+ (:finish-output
+ (log-stream-op stream operation)
+ (system:without-interrupts
+ (let ((end (sos.index stream)))
+ (unless (zerop end)
+ (let ((s (subseq (sos.buffer stream) 0 end)))
+ (setf (sos.index stream) 0)
+ (funcall (sos.output-fn stream) s))
+ (setf (sos.last-flush-time stream) (get-internal-real-time)))))
+ nil)
+ (:force-output
+ (log-stream-op stream operation)
+ (sos/misc-force-output stream)
+ nil)
+ (:charpos (sos.column stream))
+ (:line-length 75)
+ (:file-position nil)
+ (:element-type 'base-char)
+ (:get-command nil)
+ (:close nil)
+ (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
+
+(defun sos/misc-force-output (stream)
+ (system:without-interrupts
+ (unless (or (zerop (sos.index stream))
+ (loop with buffer = (sos.buffer stream)
+ for i from 0 below (sos.index stream)
+ always (char= (aref buffer i) #\newline)))
+ (let ((last (sos.last-flush-time stream))
+ (now (get-internal-real-time)))
+ (when (> (/ (- now last)
+ (coerce internal-time-units-per-second 'double-float))
+ 0.1)
+ (finish-output stream))))))
+
+(defstruct (slime-input-stream
+ (: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)
+ (finish-output (sis.sos stream))
+ (let ((index (sis.index stream))
+ (buffer (sis.buffer stream)))
+ (when (= index (length buffer))
+ (let ((string (funcall (sis.input-fn stream))))
+ (cond ((zerop (length string))
+ (return-from sis/in
+ (if eof-errorp
+ (error (make-condition 'end-of-file :stream stream))
+ eof-value)))
+ (t
+ (setf buffer string)
+ (setf (sis.buffer stream) buffer)
+ (setf index 0)))))
+ (prog1 (aref buffer index)
+ (setf (sis.index stream) (1+ index)))))
+
+(defun sis/misc (stream operation &optional arg1 arg2)
+ (declare (ignore arg2))
+ (ecase operation
+ (:file-position nil)
+ (:file-length nil)
+ (:unread (setf (aref (sis.buffer stream)
+ (decf (sis.index stream)))
+ arg1))
+ (:clear-input
+ (setf (sis.index stream) 0
+ (sis.buffer stream) ""))
+ (:listen (< (sis.index stream) (length (sis.buffer stream))))
+ (:charpos nil)
+ (:line-length nil)
+ (:get-command nil)
+ (:element-type 'base-char)
+ (:close nil)
+ (:interactive-p t)))
+
+
+;;;; Compilation Commands
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Previous compiler error context.")
+
+(defvar *buffer-name* nil
+ "The name of the Emacs buffer we are compiling from.
+NIL if we aren't compiling from a buffer.")
+
+(defvar *buffer-start-position* nil)
+(defvar *buffer-substring* nil)
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((*previous-compiler-condition* nil)
+ (*previous-context* nil)
+ (*print-readably* nil))
+ (handler-bind ((c::compiler-error #'handle-notification-condition)
+ (c::style-warning #'handle-notification-condition)
+ (c::warning #'handle-notification-condition))
+ (funcall function))))
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (declare (ignore external-format))
+ (clear-xref-info filename)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (compile-file filename)
+ (unless failure-p
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get filename (file-write-date filename))
+ (when load-p (load output-file)))
+ (values output-file warnings-p failure-p)))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-substring* string))
+ (with-input-from-string (stream string)
+ (ext:compile-from-stream
+ stream
+ :source-info `(:emacs-buffer ,buffer
+ :emacs-buffer-offset ,position
+ :emacs-buffer-string ,string))))))
+
+
+;;;;; Trapping notes
+;;;
+;;; We intercept conditions from the compiler and resignal them as
+;;; `SWANK:COMPILER-CONDITION's.
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (unless (eq condition *previous-compiler-condition*)
+ (let ((context (c::find-error-context nil)))
+ (setq *previous-compiler-condition* condition)
+ (setq *previous-context* context)
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :severity (severity-for-emacs condition)
+ :short-message (brief-compiler-message-for-emacs condition)
+ :message (long-compiler-message-for-emacs condition context)
+ :location (if (read-error-p condition)
+ (read-error-location condition)
+ (compiler-note-location context)))))
+
+(defun severity-for-emacs (condition)
+ "Return the severity of CONDITION."
+ (etypecase condition
+ ((satisfies read-error-p) :read-error)
+ (c::compiler-error :error)
+ (c::style-warning :note)
+ (c::warning :warning)))
+
+(defun read-error-p (condition)
+ (eq (type-of condition) 'c::compiler-read-error))
+
+(defun brief-compiler-message-for-emacs (condition)
+ "Briefly describe a compiler error for Emacs.
+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."
+ (princ-to-string condition))
+
+(defun long-compiler-message-for-emacs (condition error-context)
+ "Describe a compiler error for Emacs including context information."
+ (declare (type (or c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (c::compiler-error-context-enclosing-source error-context)
+ (c::compiler-error-context-source error-context)))
+ (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
+ enclosing source condition)))
+
+(defun read-error-location (condition)
+ (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
+ (file (c::file-info-name finfo))
+ (pos (c::compiler-read-error-position condition)))
+ (cond ((and (eq file :stream) *buffer-name*)
+ (make-location (list :buffer *buffer-name*)
+ (list :position (+ *buffer-start-position* pos))))
+ ((and (pathnamep file) (not *buffer-name*))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ pos))))
+ (t (break)))))
+
+(defun compiler-note-location (context)
+ "Derive the location of a complier message from its context.
+Return a `location' record, or (:error REASON) on failure."
+ (if (null context)
+ (note-error-location)
+ (let ((file (c::compiler-error-context-file-name context))
+ (source (c::compiler-error-context-original-source context))
+ (path
+ (reverse (c::compiler-error-context-original-source-path context))))
+ (or (locate-compiler-note file source path)
+ (note-error-location)))))
+
+(defun note-error-location ()
+ "Pseudo-location for notes that can't be located."
+ (list :error "No error location available."))
+
+(defun locate-compiler-note (file source source-path)
+ (cond ((and (eq file :stream) *buffer-name*)
+ ;; Compiling from a buffer
+ (let ((position (+ *buffer-start-position*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ (make-location (list :buffer *buffer-name*)
+ (list :position position))))
+ ((and (pathnamep file) (null *buffer-name*))
+ ;; Compiling from a file
+ (make-location (list :file (unix-truename file))
+ (list :position
+ (1+ (source-path-file-position
+ source-path file)))))
+ ((and (eq file :lisp) (stringp source))
+ ;; No location known, but we have the source form.
+ ;; XXX How is this case triggered? -luke (16/May/2004)
+ ;; This can happen if the compiler needs to expand a macro
+ ;; but the macro-expander is not yet compiled. Calling the
+ ;; (interpreted) macro-expander triggers IR1 conversion of
+ ;; the lambda expression for the expander and invokes the
+ ;; compiler recursively.
+ (make-location (list :source-form source)
+ (list :position 1)))))
+
+(defun unix-truename (pathname)
+ (ext:unix-namestring (truename pathname)))
+
+
+;;;; XREF
+;;;
+;;; Cross-reference support is based on the standard CMUCL `XREF'
+;;; package. This package has some caveats: XREF information is
+;;; recorded during compilation and not preserved in fasl files, and
+;;; XREF recording is disabled by default. Redefining functions can
+;;; also cause duplicate references to accumulate, but
+;;; `swank-compile-file' will automatically clear out any old records
+;;; from the same filename.
+;;;
+;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
+;;; clear out the XREF database call `xref:init-xref-database'.
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls xref:who-calls)
+(defxref who-references xref:who-references)
+(defxref who-binds xref:who-binds)
+(defxref who-sets xref:who-sets)
+
+;;; More types of XREF information were added since 18e:
+;;;
+#+cmu19
+(progn
+ (defxref who-macroexpands xref:who-macroexpands)
+ ;; XXX
+ (defimplementation who-specializes (symbol)
+ (let* ((methods (xref::who-specializes (find-class symbol)))
+ (locations (mapcar #'method-location methods)))
+ (mapcar #'list methods locations))))
+
+(defun xref-results (contexts)
+ (mapcar (lambda (xref)
+ (list (xref:xref-context-name xref)
+ (resolve-xref-location xref)))
+ contexts))
+
+(defun resolve-xref-location (xref)
+ (let ((name (xref:xref-context-name xref))
+ (file (xref:xref-context-file xref))
+ (source-path (xref:xref-context-source-path xref)))
+ (cond ((and file source-path)
+ (let ((position (source-path-file-position source-path file)))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ position)))))
+ (file
+ (make-location (list :file (unix-truename file))
+ (list :function-name (string name))))
+ (t
+ `(:error ,(format nil "Unknown source location: ~S ~S ~S "
+ name file source-path))))))
+
+(defun clear-xref-info (namestring)
+ "Clear XREF notes pertaining to NAMESTRING.
+This is a workaround for a CMUCL bug: XREF records are cumulative."
+ (when c:*record-xref-info*
+ (let ((filename (truename namestring)))
+ (dolist (db (list xref::*who-calls*
+ #+cmu19 xref::*who-is-called*
+ #+cmu19 xref::*who-macroexpands*
+ xref::*who-references*
+ xref::*who-binds*
+ xref::*who-sets*))
+ (maphash (lambda (target contexts)
+ ;; XXX update during traversal?
+ (setf (gethash target db)
+ (delete filename contexts
+ :key #'xref:xref-context-file
+ :test #'equalp)))
+ db)))))
+
+
+;;;; Find callers and callees
+;;;
+;;; Find callers and callees by looking at the constant pool of
+;;; compiled code objects. We assume every fdefn object in the
+;;; constant pool corresponds to a call to that function. A better
+;;; strategy would be to use the disassembler to find actual
+;;; call-sites.
+
+(declaim (inline map-code-constants))
+(defun map-code-constants (code fn)
+ "Call FN for each constant in CODE's constant pool."
+ (check-type code kernel:code-component)
+ (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
+ do (funcall fn (kernel:code-header-ref code i))))
+
+(defun function-callees (function)
+ "Return FUNCTION's callees as a list of functions."
+ (let ((callees '()))
+ (map-code-constants
+ (vm::find-code-object function)
+ (lambda (obj)
+ (when (kernel:fdefn-p obj)
+ (push (kernel:fdefn-function obj) callees))))
+ callees))
+
+(declaim (ext:maybe-inline map-allocated-code-components))
+(defun map-allocated-code-components (spaces fn)
+ "Call FN for each allocated code component in one of SPACES. FN
+receives the object as argument. SPACES should be a list of the
+symbols :dynamic, :static, or :read-only."
+ (dolist (space spaces)
+ (declare (inline vm::map-allocated-objects)
+ (optimize (ext:inhibit-warnings 3)))
+ (vm::map-allocated-objects
+ (lambda (obj header size)
+ (declare (type fixnum size) (ignore size))
+ (when (= vm:code-header-type header)
+ (funcall fn obj)))
+ space)))
+
+(declaim (ext:maybe-inline map-caller-code-components))
+(defun map-caller-code-components (function spaces fn)
+ "Call FN for each code component with a fdefn for FUNCTION in its
+constant pool."
+ (let ((function (coerce function 'function)))
+ (declare (inline map-allocated-code-components))
+ (map-allocated-code-components
+ spaces
+ (lambda (obj)
+ (map-code-constants
+ obj
+ (lambda (constant)
+ (when (and (kernel:fdefn-p constant)
+ (eq (kernel:fdefn-function constant)
+ function))
+ (funcall fn obj))))))))
+
+(defun function-callers (function &optional (spaces '(:read-only :static
+ :dynamic)))
+ "Return FUNCTION's callers. The result is a list of code-objects."
+ (let ((referrers '()))
+ (declare (inline map-caller-code-components))
+ ;;(ext:gc :full t)
+ (map-caller-code-components function spaces
+ (lambda (code) (push code referrers)))
+ referrers))
+
+(defun debug-info-definitions (debug-info)
+ "Return the defintions for a debug-info. This should only be used
+for code-object without entry points, i.e., byte compiled
+code (are theree others?)"
+ ;; This mess has only been tested with #'ext::skip-whitespace, a
+ ;; byte-compiled caller of #'read-char .
+ (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
+ (let ((name (c::debug-info-name debug-info))
+ (source (c::debug-info-source debug-info)))
+ (destructuring-bind (first) source
+ (ecase (c::debug-source-from first)
+ (:file
+ (list (list name
+ (make-location
+ (list :file (unix-truename (c::debug-source-name first)))
+ (list :function-name (string name))))))))))
+
+(defun code-component-entry-points (code)
+ "Return a list ((NAME LOCATION) ...) of function definitons for
+the code omponent CODE."
+ (let ((names '()))
+ (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
+ ((not f))
+ (let ((name (kernel:%function-name f)))
+ (when (ext:valid-function-name-p name)
+ (push (list name (function-location f)) names))))
+ names))
+
+(defimplementation list-callers (symbol)
+ "Return a list ((NAME LOCATION) ...) of callers."
+ (let ((components (function-callers symbol))
+ (xrefs '()))
+ (dolist (code components)
+ (let* ((entry (kernel:%code-entry-points code))
+ (defs (if entry
+ (code-component-entry-points code)
+ ;; byte compiled stuff
+ (debug-info-definitions
+ (kernel:%code-debug-info code)))))
+ (setq xrefs (nconc defs xrefs))))
+ xrefs))
+
+(defimplementation list-callees (symbol)
+ (let ((fns (function-callees symbol)))
+ (mapcar (lambda (fn)
+ (list (kernel:%function-name fn)
+ (function-location fn)))
+ fns)))
+
+
+;;;; Resolving source locations
+;;;
+;;; Our mission here is to "resolve" references to code locations into
+;;; actual file/buffer names and character positions. The references
+;;; we work from come out of the compiler's statically-generated debug
+;;; information, such as `code-location''s and `debug-source''s. For
+;;; more details, see the "Debugger Programmer's Interface" section of
+;;; the CMUCL manual.
+;;;
+;;; The first step is usually to find the corresponding "source-path"
+;;; for the location. Once we have the source-path we can pull up the
+;;; source file and `READ' our way through to the right position. The
+;;; main source-code groveling work is done in
+;;; `swank-source-path-parser.lisp'.
+
+(defvar *debug-definition-finding* nil
+ "When true don't handle errors while looking for definitions.
+This is useful when debugging the definition-finding code.")
+
+(defvar *source-snippet-size* 256
+ "Maximum number of characters in a snippet of source code.
+Snippets at the beginning of definitions are used to tell Emacs what
+the definitions looks like, so that it can accurately find them by
+text search.")
+
+(defmacro safe-definition-finding (&body body)
+ "Execute BODY and return the source-location it returns.
+If an error occurs and `*debug-definition-finding*' is false, then
+return an error pseudo-location.
+
+The second return value is NIL if no error occurs, otherwise it is the
+condition object."
+ `(flet ((body () ,@body))
+ (if *debug-definition-finding*
+ (body)
+ (handler-case (values (progn ,@body) nil)
+ (error (c) (values `(:error ,(trim-whitespace (princ-to-string c)))
+ c))))))
+
+(defun trim-whitespace (string)
+ (string-trim #(#\newline #\space #\tab) string))
+
+(defun code-location-source-location (code-location)
+ "Safe wrapper around `code-location-from-source-location'."
+ (safe-definition-finding
+ (source-location-from-code-location code-location)))
+
+(defun source-location-from-code-location (code-location)
+ "Return the source location for CODE-LOCATION."
+ (let ((debug-fun (di:code-location-debug-function code-location)))
+ (when (di::bogus-debug-function-p debug-fun)
+ ;; Those lousy cheapskates! They've put in a bogus debug source
+ ;; because the code was compiled at a low debug setting.
+ (error "Bogus debug function: ~A" debug-fun)))
+ (let* ((debug-source (di:code-location-debug-source code-location))
+ (from (di:debug-source-from debug-source))
+ (name (di:debug-source-name debug-source)))
+ (ecase from
+ (:file
+ (location-in-file name code-location debug-source))
+ (:stream
+ (location-in-stream code-location debug-source))
+ (:lisp
+ ;; The location comes from a form passed to `compile'.
+ ;; The best we can do is return the form itself for printing.
+ (make-location
+ (list :source-form (with-output-to-string (*standard-output*)
+ (debug::print-code-location-source-form
+ code-location 100 t)))
+ (list :position 1))))))
+
+(defun location-in-file (filename code-location debug-source)
+ "Resolve the source location for CODE-LOCATION in FILENAME."
+ (let* ((code-date (di:debug-source-created debug-source))
+ (source-code (get-source-code filename code-date)))
+ (with-input-from-string (s source-code)
+ (make-location (list :file (unix-truename filename))
+ (list :position (1+ (code-location-stream-position
+ code-location s)))
+ `(:snippet ,(read-snippet s))))))
+
+(defun location-in-stream (code-location debug-source)
+ "Resolve the source location for a CODE-LOCATION from a stream.
+This only succeeds if the code was compiled from an Emacs buffer."
+ (unless (debug-source-info-from-emacs-buffer-p debug-source)
+ (error "The code is compiled from a non-SLIME stream."))
+ (let* ((info (c::debug-source-info debug-source))
+ (string (getf info :emacs-buffer-string))
+ (position (code-location-string-offset
+ code-location
+ string)))
+ (make-location
+ (list :buffer (getf info :emacs-buffer))
+ (list :position (+ (getf info :emacs-buffer-offset) position))
+ (list :snippet (with-input-from-string (s string)
+ (file-position s position)
+ (read-snippet s))))))
+
+;;;;; Function-name locations
+;;;
+(defun debug-info-function-name-location (debug-info)
+ "Return a function-name source-location for DEBUG-INFO.
+Function-name source-locations are a fallback for when precise
+positions aren't available."
+ (with-struct (c::debug-info- (fname name) source) debug-info
+ (with-struct (c::debug-source- info from name) (car source)
+ (ecase from
+ (:file
+ (make-location (list :file (namestring (truename name)))
+ (list :function-name (string fname))))
+ (:stream
+ (assert (debug-source-info-from-emacs-buffer-p (car source)))
+ (make-location (list :buffer (getf info :emacs-buffer))
+ (list :function-name (string fname))))
+ (:lisp
+ (make-location (list :source-form (princ-to-string (aref name 0)))
+ (list :position 1)))))))
+
+(defun debug-source-info-from-emacs-buffer-p (debug-source)
+ "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
+This is true for functions that were compiled directly from buffers."
+ (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
+
+(defun info-from-emacs-buffer-p (info)
+ (and info
+ (consp info)
+ (eq :emacs-buffer (car info))))
+
+
+;;;;; Groveling source-code for positions
+
+(defun code-location-stream-position (code-location stream)
+ "Return the byte offset of CODE-LOCATION in STREAM. Extract the
+toplevel-form-number and form-number from CODE-LOCATION and use that
+to find the position of the corresponding form.
+
+Finish with STREAM positioned at the start of the code location."
+ (let* ((location (debug::maybe-block-start-location code-location))
+ (tlf-offset (di:code-location-top-level-form-offset location))
+ (form-number (di:code-location-form-number location)))
+ (let ((pos (form-number-stream-position tlf-offset form-number stream)))
+ (file-position stream pos)
+ pos)))
+
+(defun form-number-stream-position (tlf-number form-number stream)
+ "Return the starting character position of a form in STREAM.
+TLF-NUMBER is the top-level-form number.
+FORM-NUMBER is an index into a source-path table for the TLF."
+ (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
+ (let* ((path-table (di:form-number-translations tlf 0))
+ (source-path
+ (if (<= (length path-table) form-number) ; source out of sync?
+ (list 0) ; should probably signal a condition
+ (reverse (cdr (aref path-table form-number))))))
+ (source-path-source-position source-path tlf position-map))))
+
+(defun code-location-string-offset (code-location string)
+ "Return the byte offset of CODE-LOCATION in STRING.
+See CODE-LOCATION-STREAM-POSITION."
+ (with-input-from-string (s string)
+ (code-location-stream-position code-location s)))
+
+
+;;;; Finding definitions
+
+;;; There are a great many different types of definition for us to
+;;; find. We search for definitions of every kind and return them in a
+;;; list.
+
+(defimplementation find-definitions (name)
+ (append (function-definitions name)
+ (setf-definitions name)
+ (variable-definitions name)
+ (class-definitions name)
+ (type-definitions name)
+ (compiler-macro-definitions name)
+ (source-transform-definitions name)
+ (function-info-definitions name)
+ (ir1-translator-definitions name)))
+
+;;;;; Functions, macros, generic functions, methods
+;;;
+;;; We make extensive use of the compile-time debug information that
+;;; CMUCL records, in particular "debug functions" and "code
+;;; locations." Refer to the "Debugger Programmer's Interface" section
+;;; of the CMUCL manual for more details.
+
+(defun function-definitions (name)
+ "Return definitions for NAME in the \"function namespace\", i.e.,
+regular functions, generic functions, methods and macros.
+NAME can any valid function name (e.g, (setf car))."
+ (let ((macro? (and (symbolp name) (macro-function name)))
+ (special? (and (symbolp name) (special-operator-p name)))
+ (function? (and (ext:valid-function-name-p name)
+ (ext:info :function :definition name)
+ (if (symbolp name) (fboundp name) t))))
+ (cond (macro?
+ (list `((defmacro ,name)
+ ,(function-location (macro-function name)))))
+ (special?
+ (list `((:special-operator ,name)
+ (:error ,(format nil "Special operator: ~S" name)))))
+ (function?
+ (let ((function (fdefinition name)))
+ (if (genericp function)
+ (generic-function-definitions name function)
+ (list (list `(function ,name)
+ (function-location function)))))))))
+
+;;;;;; Ordinary (non-generic/macro/special) functions
+;;;
+;;; First we test if FUNCTION is a closure created by defstruct, and
+;;; if so extract the defstruct-description (`dd') from the closure
+;;; and find the constructor for the struct. Defstruct creates a
+;;; defun for the default constructor and we use that as an
+;;; approximation to the source location of the defstruct.
+;;;
+;;; For an ordinary function we return the source location of the
+;;; first code-location we find.
+;;;
+(defun function-location (function)
+ "Return the source location for FUNCTION."
+ (cond ((struct-closure-p function)
+ (struct-closure-location function))
+ ((c::byte-function-or-closure-p function)
+ (byte-function-location function))
+ (t
+ (compiled-function-location function))))
+
+(defun compiled-function-location (function)
+ "Return the location of a regular compiled function."
+ (multiple-value-bind (code-location error)
+ (safe-definition-finding (function-first-code-location function))
+ (cond (error (list :error (princ-to-string error)))
+ (t (code-location-source-location code-location)))))
+
+(defun function-first-code-location (function)
+ "Return the first code-location we can find for FUNCTION."
+ (and (function-has-debug-function-p function)
+ (di:debug-function-start-location
+ (di:function-debug-function function))))
+
+(defun function-has-debug-function-p (function)
+ (di:function-debug-function function))
+
+(defun function-code-object= (closure function)
+ (and (eq (vm::find-code-object closure)
+ (vm::find-code-object function))
+ (not (eq closure function))))
+
+(defun byte-function-location (fun)
+ "Return the location of the byte-compiled function FUN."
+ (etypecase fun
+ ((or c::hairy-byte-function c::simple-byte-function)
+ (let* ((di (kernel:%code-debug-info (c::byte-function-component fun))))
+ (if di
+ (debug-info-function-name-location di)
+ `(:error
+ ,(format nil "Byte-function without debug-info: ~a" fun)))))
+ (c::byte-closure
+ (byte-function-location (c::byte-closure-function fun)))))
+
+;;; Here we deal with structure accessors. Note that `dd' is a
+;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
+;;; `defstruct''d structure.
+
+(defun struct-closure-p (function)
+ "Is FUNCTION a closure created by defstruct?"
+ (or (function-code-object= function #'kernel::structure-slot-accessor)
+ (function-code-object= function #'kernel::structure-slot-setter)
+ (function-code-object= function #'kernel::%defstruct)))
+
+(defun struct-closure-location (function)
+ "Return the location of the structure that FUNCTION belongs to."
+ (assert (struct-closure-p function))
+ (safe-definition-finding
+ (dd-location (struct-closure-dd function))))
+
+(defun struct-closure-dd (function)
+ "Return the defstruct-definition (dd) of FUNCTION."
+ (assert (= (kernel:get-type function) vm:closure-header-type))
+ (flet ((find-layout (function)
+ (sys:find-if-in-closure
+ (lambda (x)
+ (let ((value (if (di::indirect-value-cell-p x)
+ (c:value-cell-ref x)
+ x)))
+ (when (kernel::layout-p value)
+ (return-from find-layout value))))
+ function)))
+ (kernel:layout-info (find-layout function))))
+
+(defun dd-location (dd)
+ "Return the location of a `defstruct'."
+ ;; Find the location in a constructor.
+ (function-location (struct-constructor dd)))
+
+(defun struct-constructor (dd)
+ "Return a constructor function from a defstruct definition.
+Signal an error if no constructor can be found."
+ (let ((constructor (or (kernel:dd-default-constructor dd)
+ (car (kernel::dd-constructors dd)))))
+ (when (or (null constructor)
+ (and (consp constructor) (null (car constructor))))
+ (error "Cannot find structure's constructor: ~S"
+ (kernel::dd-name dd)))
+ (coerce (if (consp constructor) (first constructor) constructor)
+ 'function)))
+
+;;;;;; Generic functions and methods
+
+(defun generic-function-definitions (name function)
+ "Return the definitions of a generic function and its methods."
+ (cons (list `(defgeneric ,name) (gf-location function))
+ (gf-method-definitions function)))
+
+(defun gf-location (gf)
+ "Return the location of the generic function GF."
+ (definition-source-location gf (pcl::generic-function-name gf)))
+
+(defun gf-method-definitions (gf)
+ "Return the locations of all methods of the generic function GF."
+ (mapcar #'method-definition (pcl::generic-function-methods gf)))
+
+(defun method-definition (method)
+ (list (method-dspec method)
+ (method-location method)))
+
+(defun method-dspec (method)
+ "Return a human-readable \"definition specifier\" for METHOD."
+ (let* ((gf (pcl:method-generic-function method))
+ (name (pcl:generic-function-name gf))
+ (specializers (pcl:method-specializers method))
+ (qualifiers (pcl:method-qualifiers method)))
+ `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
+
+;; XXX maybe special case setters/getters
+(defun method-location (method)
+ (function-location (or (pcl::method-fast-function method)
+ (pcl:method-function method))))
+
+(defun genericp (fn)
+ (typep fn 'generic-function))
+
+;;;;;; Types and classes
+
+(defun type-definitions (name)
+ "Return `deftype' locations for type NAME."
+ (maybe-make-definition (ext:info :type :expander name) 'deftype name))
+
+(defun maybe-make-definition (function kind name)
+ "If FUNCTION is non-nil then return its definition location."
+ (if function
+ (list (list `(,kind ,name) (function-location function)))))
+
+(defun class-definitions (name)
+ "Return the definition locations for the class called NAME."
+ (if (symbolp name)
+ (let ((class (kernel::find-class name nil)))
+ (etypecase class
+ (null '())
+ (kernel::structure-class
+ (list (list `(defstruct ,name) (dd-location (find-dd name)))))
+ #+(or)
+ (conditions::condition-class
+ (list (list `(define-condition ,name)
+ (condition-class-location class))))
+ (kernel::standard-class
+ (list (list `(defclass ,name)
+ (class-location (find-class name)))))
+ ((or kernel::built-in-class
+ conditions::condition-class
+ kernel:funcallable-structure-class)
+ (list (list `(kernel::define-type-class ,name)
+ `(:error
+ ,(format nil "No source info for ~A" name)))))))))
+
+(defun class-location (class)
+ "Return the `defclass' location for CLASS."
+ (definition-source-location class (pcl:class-name class)))
+
+(defun find-dd (name)
+ "Find the defstruct-definition by the name of its structure-class."
+ (let ((layout (ext:info :type :compiler-layout name)))
+ (if layout
+ (kernel:layout-info layout))))
+
+(defun condition-class-location (class)
+ (let ((slots (conditions::condition-class-slots class))
+ (name (conditions::condition-class-name class)))
+ (cond ((null slots)
+ `(:error ,(format nil "No location info for condition: ~A" name)))
+ (t
+ ;; Find the class via one of its slot-reader methods.
+ (let* ((slot (first slots))
+ (gf (fdefinition
+ (first (conditions::condition-slot-readers slot)))))
+ (method-location
+ (first
+ (pcl:compute-applicable-methods-using-classes
+ gf (list (find-class name))))))))))
+
+(defun make-name-in-file-location (file string)
+ (multiple-value-bind (filename c)
+ (ignore-errors
+ (unix-truename (merge-pathnames (make-pathname :type "lisp")
+ file)))
+ (cond (filename (make-location `(:file ,filename)
+ `(:function-name ,(string string))))
+ (t (list :error (princ-to-string c))))))
+
+(defun source-location-form-numbers (location)
+ (c::decode-form-numbers (c::form-numbers-form-numbers location)))
+
+(defun source-location-tlf-number (location)
+ (nth-value 0 (source-location-form-numbers location)))
+
+(defun source-location-form-number (location)
+ (nth-value 1 (source-location-form-numbers location)))
+
+(defun resolve-file-source-location (location)
+ (let ((filename (c::file-source-location-pathname location))
+ (tlf-number (source-location-tlf-number location))
+ (form-number (source-location-form-number location)))
+ (with-open-file (s filename)
+ (let ((pos (form-number-stream-position tlf-number form-number s)))
+ (make-location `(:file ,(unix-truename filename))
+ `(:position ,(1+ pos)))))))
+
+(defun resolve-stream-source-location (location)
+ (let ((info (c::stream-source-location-user-info location))
+ (tlf-number (source-location-tlf-number location))
+ (form-number (source-location-form-number location)))
+ ;; XXX duplication in frame-source-location
+ (assert (info-from-emacs-buffer-p info))
+ (destructuring-bind (&key emacs-buffer emacs-buffer-string
+ emacs-buffer-offset) info
+ (with-input-from-string (s emacs-buffer-string)
+ (let ((pos (form-number-stream-position tlf-number form-number s)))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:position ,(+ emacs-buffer-offset pos))))))))
+
+;; XXX predicates for 18e backward compatibilty. Remove them when
+;; we're 19a only.
+(defun file-source-location-p (object)
+ (when (fboundp 'c::file-source-location-p)
+ (c::file-source-location-p object)))
+
+(defun stream-source-location-p (object)
+ (when (fboundp 'c::stream-source-location-p)
+ (c::stream-source-location-p object)))
+
+(defun source-location-p (object)
+ (or (file-source-location-p object)
+ (stream-source-location-p object)))
+
+(defun resolve-source-location (location)
+ (etypecase location
+ ((satisfies file-source-location-p)
+ (resolve-file-source-location location))
+ ((satisfies stream-source-location-p)
+ (resolve-stream-source-location location))))
+
+(defun definition-source-location (object name)
+ (let ((source (pcl::definition-source object)))
+ (etypecase source
+ (null
+ `(:error ,(format nil "No source info for: ~A" object)))
+ ((satisfies source-location-p)
+ (resolve-source-location source))
+ (pathname
+ (make-name-in-file-location source name))
+ (cons
+ (destructuring-bind ((dg name) pathname) source
+ (declare (ignore dg))
+ (etypecase pathname
+ (pathname (make-name-in-file-location pathname (string name)))
+ (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
+
+(defun setf-definitions (name)
+ (let ((function (or (ext:info :setf :inverse name)
+ (ext:info :setf :expander name)
+ (and (symbolp name)
+ (fboundp `(setf ,name))
+ (fdefinition `(setf ,name))))))
+ (if function
+ (list (list `(setf ,name)
+ (function-location (coerce function 'function)))))))
+
+
+(defun variable-location (symbol)
+ (multiple-value-bind (location foundp)
+ ;; XXX for 18e compatibilty. rewrite this when we drop 18e
+ ;; support.
+ (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
+ (if (and foundp location)
+ (resolve-source-location location)
+ `(:error ,(format nil "No source info for variable ~S" symbol)))))
+
+(defun variable-definitions (name)
+ (if (symbolp name)
+ (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
+ (if recorded-p
+ (list (list `(variable ,kind ,name)
+ (variable-location name)))))))
+
+(defun compiler-macro-definitions (symbol)
+ (maybe-make-definition (compiler-macro-function symbol)
+ 'define-compiler-macro
+ symbol))
+
+(defun source-transform-definitions (name)
+ (maybe-make-definition (ext:info :function :source-transform name)
+ 'c:def-source-transform
+ name))
+
+(defun function-info-definitions (name)
+ (let ((info (ext:info :function :info name)))
+ (if info
+ (append (loop for transform in (c::function-info-transforms info)
+ collect (list `(c:deftransform ,name
+ ,(c::type-specifier
+ (c::transform-type transform)))
+ (function-location (c::transform-function
+ transform))))
+ (maybe-make-definition (c::function-info-derive-type info)
+ 'c::derive-type name)
+ (maybe-make-definition (c::function-info-optimizer info)
+ 'c::optimizer name)
+ (maybe-make-definition (c::function-info-ltn-annotate info)
+ 'c::ltn-annotate name)
+ (maybe-make-definition (c::function-info-ir2-convert info)
+ 'c::ir2-convert name)
+ (loop for template in (c::function-info-templates info)
+ collect (list `(c::vop ,(c::template-name template))
+ (function-location
+ (c::vop-info-generator-function
+ template))))))))
+
+(defun ir1-translator-definitions (name)
+ (maybe-make-definition (ext:info :function :ir1-convert name)
+ 'c:def-ir1-translator name))
+
+
+;;;; Documentation.
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (multiple-value-bind (kind recorded-p)
+ (ext:info variable kind symbol)
+ (declare (ignore kind))
+ (if (or (boundp symbol) recorded-p)
+ (doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((genericp (fdefinition symbol)) :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (if (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol))
+ (doc 'setf)))
+ (maybe-push
+ :type (if (ext:info type kind symbol)
+ (doc 'type)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ (maybe-push
+ :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
+ (doc 'alien-type)))
+ (maybe-push
+ :alien-struct (if (ext:info alien-type struct symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-union (if (ext:info alien-type union symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-enum (if (ext:info alien-type enum symbol)
+ (doc nil)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (describe (ecase namespace
+ (:variable
+ symbol)
+ ((:function :generic-function)
+ (symbol-function symbol))
+ (:setf
+ (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol)))
+ (:type
+ (kernel:values-specifier-type symbol))
+ (:class
+ (find-class symbol))
+ (:alien-struct
+ (ext:info :alien-type :struct symbol))
+ (:alien-union
+ (ext:info :alien-type :union symbol))
+ (:alien-enum
+ (ext:info :alien-type :enum symbol))
+ (:alien-type
+ (ecase (ext:info :alien-type :kind symbol)
+ (:primitive
+ (let ((alien::*values-type-okay* t))
+ (funcall (ext:info :alien-type :translator symbol)
+ (list symbol))))
+ ((:defined)
+ (ext:info :alien-type :definition symbol))
+ (:unknown :unkown))))))
+
+;;;;; Argument lists
+
+(defimplementation arglist (fun)
+ (etypecase fun
+ (function (function-arglist fun))
+ (symbol (function-arglist (or (macro-function fun)
+ (symbol-function fun))))))
+
+(defun function-arglist (fun)
+ (let ((arglist
+ (cond ((eval:interpreted-function-p fun)
+ (eval:interpreted-function-arglist fun))
+ ((pcl::generic-function-p fun)
+ (pcl:generic-function-lambda-list fun))
+ ((c::byte-function-or-closure-p fun)
+ (byte-code-function-arglist fun))
+ ((kernel:%function-arglist (kernel:%function-self fun))
+ (handler-case (read-arglist fun)
+ (error () :not-available)))
+ ;; this should work both for compiled-debug-function
+ ;; and for interpreted-debug-function
+ (t
+ (handler-case (debug-function-arglist
+ (di::function-debug-function fun))
+ (di:unhandled-condition () :not-available))))))
+ (check-type arglist (or list (member :not-available)))
+ arglist))
+
+(defimplementation function-name (function)
+ (cond ((eval:interpreted-function-p function)
+ (eval:interpreted-function-name function))
+ ((pcl::generic-function-p function)
+ (pcl::generic-function-name function))
+ ((c::byte-function-or-closure-p function)
+ (c::byte-function-name function))
+ (t (kernel:%function-name (kernel:%function-self function)))))
+
+;;; A simple case: the arglist is available as a string that we can
+;;; `read'.
+
+(defun read-arglist (fn)
+ "Parse the arglist-string of the function object FN."
+ (let ((string (kernel:%function-arglist
+ (kernel:%function-self fn)))
+ (package (find-package
+ (c::compiled-debug-info-package
+ (kernel:%code-debug-info
+ (vm::find-code-object fn))))))
+ (with-standard-io-syntax
+ (let ((*package* (or package *package*)))
+ (read-from-string string)))))
+
+;;; A harder case: an approximate arglist is derived from available
+;;; debugging information.
+
+(defun debug-function-arglist (debug-function)
+ "Derive the argument list of DEBUG-FUNCTION from debug info."
+ (let ((args (di::debug-function-lambda-list debug-function))
+ (required '())
+ (optional '())
+ (rest '())
+ (key '()))
+ ;; collect the names of debug-vars
+ (dolist (arg args)
+ (etypecase arg
+ (di::debug-variable
+ (push (di::debug-variable-symbol arg) required))
+ ((member :deleted)
+ (push ':deleted required))
+ (cons
+ (ecase (car arg)
+ (:keyword
+ (push (second arg) key))
+ (:optional
+ (push (debug-variable-symbol-or-deleted (second arg)) optional))
+ (:rest
+ (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
+ ;; intersperse lambda keywords as needed
+ (append (nreverse required)
+ (if optional (cons '&optional (nreverse optional)))
+ (if rest (cons '&rest (nreverse rest)))
+ (if key (cons '&key (nreverse key))))))
+
+(defun debug-variable-symbol-or-deleted (var)
+ (etypecase var
+ (di:debug-variable
+ (di::debug-variable-symbol var))
+ ((member :deleted)
+ '#:deleted)))
+
+(defun symbol-debug-function-arglist (fname)
+ "Return FNAME's debug-function-arglist and %function-arglist.
+A utility for debugging DEBUG-FUNCTION-ARGLIST."
+ (let ((fn (fdefinition fname)))
+ (values (debug-function-arglist (di::function-debug-function fn))
+ (kernel:%function-arglist (kernel:%function-self fn)))))
+
+;;; Deriving arglists for byte-compiled functions:
+;;;
+(defun byte-code-function-arglist (fn)
+ ;; There doesn't seem to be much arglist information around for
+ ;; byte-code functions. Use the arg-count and return something like
+ ;; (arg0 arg1 ...)
+ (etypecase fn
+ (c::simple-byte-function
+ (loop for i from 0 below (c::simple-byte-function-num-args fn)
+ collect (make-arg-symbol i)))
+ (c::hairy-byte-function
+ (hairy-byte-function-arglist fn))
+ (c::byte-closure
+ (byte-code-function-arglist (c::byte-closure-function fn)))))
+
+(defun make-arg-symbol (i)
+ (make-symbol (format nil "~A~D" (string 'arg) i)))
+
+;;; A "hairy" byte-function is one that takes a variable number of
+;;; arguments. `hairy-byte-function' is a type from the bytecode
+;;; interpreter.
+;;;
+(defun hairy-byte-function-arglist (fn)
+ (let ((counter -1))
+ (flet ((next-arg () (make-arg-symbol (incf counter))))
+ (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
+ keywords-p keywords) fn
+ (let ((arglist '())
+ (optional (- max-args min-args)))
+ ;; XXX isn't there a better way to write this?
+ ;; (Looks fine to me. -luke)
+ (dotimes (i min-args)
+ (push (next-arg) arglist))
+ (when (plusp optional)
+ (push '&optional arglist)
+ (dotimes (i optional)
+ (push (next-arg) arglist)))
+ (when rest-arg-p
+ (push '&rest arglist)
+ (push (next-arg) arglist))
+ (when keywords-p
+ (push '&key arglist)
+ (loop for (key _ __) in keywords
+ do (push key arglist))
+ (when (eq keywords-p :allow-others)
+ (push '&allow-other-keys arglist)))
+ (nreverse arglist))))))
+
+
+;;;; Miscellaneous.
+
+(defimplementation macroexpand-all (form)
+ (walker:macroexpand-all form))
+
+(defimplementation compiler-macroexpand-1 (form &optional env)
+ (ext:compiler-macroexpand-1 form env))
+
+(defimplementation compiler-macroexpand (form &optional env)
+ (ext:compiler-macroexpand form env))
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:default-directory)))
+
+(defimplementation call-without-interrupts (fn)
+ (sys:without-interrupts (funcall fn)))
+
+(defimplementation getpid ()
+ (unix:unix-getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "cmucl")
+
+(defimplementation quit-lisp ()
+ (ext::quit))
+
+;;; source-path-{stream,file,string,etc}-position moved into
+;;; swank-source-path-parser
+
+
+;;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (unix:unix-sigsetmask 0)
+ (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+ (debug:*stack-top-hint* nil)
+ (kernel:*current-level* 0))
+ (handler-bind ((di::unhandled-condition
+ (lambda (condition)
+ (error (make-condition
+ 'sldb-condition
+ :original-condition condition)))))
+ (unwind-protect
+ (progn
+ #+(or)(sys:scrub-control-stack)
+ (funcall debugger-loop-fn))
+ #+(or)(sys:scrub-control-stack)
+ ))))
+
+(defun frame-down (frame)
+ (handler-case (di:frame-down frame)
+ (di:no-debug-info () nil)))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (frame-down f)
+ for i from start below end
+ while f
+ collect f)))
+
+(defimplementation print-frame (frame stream)
+ (let ((*standard-output* stream))
+ (handler-case
+ (debug::print-frame-call frame :verbosity 1 :number nil)
+ (error (e)
+ (ignore-errors (princ e stream))))))
+
+(defimplementation frame-source-location-for-emacs (index)
+ (code-location-source-location (di:frame-code-location (nth-frame index))))
+
+(defimplementation eval-in-frame (form index)
+ (di:eval-in-frame (nth-frame index) form))
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (di::debug-function-debug-variables (di:frame-debug-function frame)))
+
+(defun debug-var-value (var frame location)
+ (let ((validity (di:debug-variable-validity var location)))
+ (ecase validity
+ (:valid (di:debug-variable-value var frame))
+ ((:invalid :unknown) (make-symbol (string validity))))))
+
+(defimplementation frame-locals (index)
+ (let* ((frame (nth-frame index))
+ (loc (di:frame-code-location frame))
+ (vars (frame-debug-vars frame)))
+ (loop for v across vars collect
+ (list :name (di:debug-variable-symbol v)
+ :id (di:debug-variable-id v)
+ :value (debug-var-value v frame loc)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame (di:frame-code-location frame))))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (di:frame-catches (nth-frame index))))
+
+(defimplementation return-from-frame (index form)
+ (let ((sym (find-symbol (string 'find-debug-tag-for-frame)
+ :debug-internals)))
+ (if sym
+ (let* ((frame (nth-frame index))
+ (probe (funcall sym frame)))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame))))
+ "return-from-frame is not implemented in this version of CMUCL.")))
+
+(defimplementation activate-stepping (frame)
+ (set-step-breakpoints (nth-frame frame)))
+
+(defimplementation sldb-break-on-return (frame)
+ (break-on-return (nth-frame frame)))
+
+;;; We set the breakpoint in the caller which might be a bit confusing.
+;;;
+(defun break-on-return (frame)
+ (let* ((caller (di:frame-down frame))
+ (cl (di:frame-code-location caller)))
+ (flet ((hook (frame bp)
+ (when (frame-pointer= frame caller)
+ (di:delete-breakpoint bp)
+ (signal-breakpoint bp frame))))
+ (let* ((info (ecase (di:code-location-kind cl)
+ ((:single-value-return :unknown-return) nil)
+ (:known-return (debug-function-returns
+ (di:frame-debug-function frame)))))
+ (bp (di:make-breakpoint #'hook cl :kind :code-location
+ :info info)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
+
+(defun frame-pointer= (frame1 frame2)
+ "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
+ (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
+
+;;; The PC in escaped frames at a single-return-value point is
+;;; actually vm:single-value-return-byte-offset bytes after the
+;;; position given in the debug info. Here we try to recognize such
+;;; cases.
+;;;
+(defun next-code-locations (frame code-location)
+ "Like `debug::next-code-locations' but be careful in escaped frames."
+ (let ((next (debug::next-code-locations code-location)))
+ (flet ((adjust-pc ()
+ (let ((cl (di::copy-compiled-code-location code-location)))
+ (incf (di::compiled-code-location-pc cl)
+ vm:single-value-return-byte-offset)
+ cl)))
+ (cond ((and (di::compiled-frame-escaped frame)
+ (eq (di:code-location-kind code-location)
+ :single-value-return)
+ (= (length next) 1)
+ (di:code-location= (car next) (adjust-pc)))
+ (debug::next-code-locations (car next)))
+ (t
+ next)))))
+
+(defun set-step-breakpoints (frame)
+ (let ((cl (di:frame-code-location frame)))
+ (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
+ (error "Cannot step in elsewhere code"))
+ (let* ((debug::*bad-code-location-types*
+ (remove :call-site debug::*bad-code-location-types*))
+ (next (next-code-locations frame cl)))
+ (cond (next
+ (let ((steppoints '()))
+ (flet ((hook (bp-frame bp)
+ (signal-breakpoint bp bp-frame)
+ (mapc #'di:delete-breakpoint steppoints)))
+ (dolist (code-location next)
+ (let ((bp (di:make-breakpoint #'hook code-location
+ :kind :code-location)))
+ (di:activate-breakpoint bp)
+ (push bp steppoints))))))
+ (t
+ (break-on-return frame))))))
+
+
+;; XXX the return values at return breakpoints should be passed to the
+;; user hooks. debug-int.lisp should be changed to do this cleanly.
+
+;;; The sigcontext and the PC for a breakpoint invocation are not
+;;; passed to user hook functions, but we need them to extract return
+;;; values. So we advice di::handle-breakpoint and bind the values to
+;;; special variables.
+;;;
+(defvar *breakpoint-sigcontext*)
+(defvar *breakpoint-pc*)
+
+;; XXX don't break old versions without fwrappers. Remove this one day.
+#+#.(cl:if (cl:find-package :fwrappers) '(and) '(or))
+(progn
+ (fwrappers:define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext)
+ (let ((*breakpoint-sigcontext* sigcontext)
+ (*breakpoint-pc* offset))
+ (fwrappers:call-next-function)))
+ (fwrappers:set-fwrappers 'di::handle-breakpoint '())
+ (fwrappers:fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext))
+
+(defun sigcontext-object (sc index)
+ "Extract the lisp object in sigcontext SC at offset INDEX."
+ (kernel:make-lisp-obj (vm:sigcontext-register sc index)))
+
+(defun known-return-point-values (sigcontext sc-offsets)
+ (let ((fp (system:int-sap (vm:sigcontext-register sigcontext
+ vm::cfp-offset))))
+ (system:without-gcing
+ (loop for sc-offset across sc-offsets
+ collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
+
+;;; CMUCL returns the first few values in registers and the rest on
+;;; the stack. In the multiple value case, the number of values is
+;;; stored in a dedicated register. The values of the registers can be
+;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
+;;; of return conventions: :single-value-return, :unknown-return, and
+;;; :known-return.
+;;;
+;;; The :single-value-return convention returns the value in a
+;;; register without setting the nargs registers.
+;;;
+;;; The :unknown-return variant is used for multiple values. A
+;;; :unknown-return point consists actually of 2 breakpoints: one for
+;;; the single value case and one for the general case. The single
+;;; value breakpoint comes vm:single-value-return-byte-offset after
+;;; the multiple value breakpoint.
+;;;
+;;; The :known-return convention is used by local functions.
+;;; :known-return is currently not supported because we don't know
+;;; where the values are passed.
+;;;
+(defun breakpoint-values (breakpoint)
+ "Return the list of return values for a return point."
+ (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
+ (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
+ (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext))))
+ (cl (di:breakpoint-what breakpoint)))
+ (ecase (di:code-location-kind cl)
+ (:single-value-return
+ (list (1st sc)))
+ (:known-return
+ (let ((info (di:breakpoint-info breakpoint)))
+ (if (vectorp info)
+ (known-return-point-values sc info)
+ (progn
+ ;;(break)
+ (list "<<known-return convention not supported>>" info)))))
+ (:unknown-return
+ (let ((mv-return-pc (di::compiled-code-location-pc cl)))
+ (if (= mv-return-pc *breakpoint-pc*)
+ (mv-function-end-breakpoint-values sc)
+ (list (1st sc)))))))))
+
+;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in
+;; newer versions of CMUCL (after ~March 2005).
+(defun mv-function-end-breakpoint-values (sigcontext)
+ (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
+ (cond (sym (funcall sym sigcontext))
+ (t (di::get-function-end-breakpoint-values sigcontext)))))
+
+(defun debug-function-returns (debug-fun)
+ "Return the return style of DEBUG-FUN."
+ (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
+ (c::compiled-debug-function-returns cdfun)))
+
+(define-condition breakpoint (simple-condition)
+ ((message :initarg :message :reader breakpoint.message)
+ (values :initarg :values :reader breakpoint.values))
+ (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+
+(defimplementation condition-extras (condition)
+ (typecase condition
+ (breakpoint
+ ;; pop up the source buffer
+ `((:show-frame-source 0)))
+ (t '())))
+
+(defun signal-breakpoint (breakpoint frame)
+ "Signal a breakpoint condition for BREAKPOINT in FRAME.
+Try to create a informative message."
+ (flet ((brk (values fstring &rest args)
+ (let ((msg (apply #'format nil fstring args))
+ (debug:*stack-top-hint* frame))
+ (break 'breakpoint :message msg :values values))))
+ (with-struct (di::breakpoint- kind what) breakpoint
+ (case kind
+ (:code-location
+ (case (di:code-location-kind what)
+ ((:single-value-return :known-return :unknown-return)
+ (let ((values (breakpoint-values breakpoint)))
+ (brk values "Return value: ~{~S ~}" values)))
+ (t
+ #+(or)
+ (when (eq (di:code-location-kind what) :call-site)
+ (call-site-function breakpoint frame))
+ (brk nil "Breakpoint: ~S ~S"
+ (di:code-location-kind what)
+ (di::compiled-code-location-pc what)))))
+ (:function-start
+ (brk nil "Function start breakpoint"))
+ (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
+
+(defimplementation sldb-break-at-start (fname)
+ (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
+ (cond ((not debug-fun)
+ `(:error ,(format nil "~S has no debug-function" fname)))
+ (t
+ (flet ((hook (frame bp &optional args cookie)
+ (declare (ignore args cookie))
+ (signal-breakpoint bp frame)))
+ (let ((bp (di:make-breakpoint #'hook debug-fun
+ :kind :function-start)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
+
+(defun frame-cfp (frame)
+ "Return the Control-Stack-Frame-Pointer for FRAME."
+ (etypecase frame
+ (di::compiled-frame (di::frame-pointer frame))
+ ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+ "Return the (absolute) instruction pointer and the relative pc of FRAME."
+ (if (not frame)
+ -1
+ (let ((debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((code-loc (di:frame-code-location frame))
+ (component (di::compiled-debug-function-component debug-fun))
+ (pc (di::compiled-code-location-pc code-loc))
+ (ip (sys:without-gcing
+ (sys:sap-int
+ (sys:sap+ (kernel:code-instructions component) pc)))))
+ (values ip pc)))
+ ((or di::bogus-debug-function di::interpreted-debug-function)
+ -1)))))
+
+(defun frame-registers (frame)
+ "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+ (let* ((cfp (frame-cfp frame))
+ (csp (frame-cfp (di::frame-up frame)))
+ (ip (frame-ip frame))
+ (ocfp (frame-cfp (di::frame-down frame)))
+ (lra (frame-ip (di::frame-down frame))))
+ (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+ (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+ (flet ((fixnum (p) (etypecase p
+ (integer p)
+ (sys:system-area-pointer (sys:sap-int p)))))
+ (apply #'format t "~
+CSP = ~X
+CFP = ~X
+IP = ~X
+OCFP = ~X
+LRA = ~X~%" (mapcar #'fixnum
+ (multiple-value-list (frame-registers frame)))))))
+
+
+(defimplementation disassemble-frame (frame-number)
+ "Return a string with the disassembly of frames code."
+ (print-frame-registers frame-number)
+ (terpri)
+ (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+ (debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((component (di::compiled-debug-function-component debug-fun))
+ (fun (di:debug-function-function debug-fun)))
+ (if fun
+ (disassemble fun)
+ (disassem:disassemble-code-component component))))
+ (di::bogus-debug-function
+ (format t "~%[Disassembling bogus frames not implemented]")))))
+
+
+;;;; Inspecting
+
+(defclass cmucl-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'cmucl-inspector))
+
+(defconstant +lowtag-symbols+
+ '(vm:even-fixnum-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:list-pointer-type
+ vm:odd-fixnum-type
+ vm:instance-pointer-type
+ vm:other-immediate-1-type
+ vm:other-pointer-type)
+ "Names of the constants that specify type tags.
+The `symbol-value' of each element is a type tag.")
+
+(defconstant +header-type-symbols+
+ (labels ((suffixp (suffix string)
+ (and (>= (length string) (length suffix))
+ (string= string suffix :start1 (- (length string)
+ (length suffix)))))
+ (header-type-symbol-p (x)
+ (and (suffixp "-TYPE" (symbol-name x))
+ (not (member x +lowtag-symbols+))
+ (boundp x)
+ (typep (symbol-value x) 'fixnum))))
+ (remove-if-not #'header-type-symbol-p
+ (append (apropos-list "-TYPE" "VM")
+ (apropos-list "-TYPE" "BIGNUM"))))
+ "A list of names of the type codes in boxed objects.")
+
+(defimplementation 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)))
+ (format t "lowtag: ~A" lowtag-symbol)
+ (when (member lowtag (list vm:other-pointer-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:other-immediate-1-type
+ ))
+ (let* ((type (kernel:get-type object))
+ (type-symbol (find type +header-type-symbols+
+ :key #'symbol-value)))
+ (format t ", type: ~A" type-symbol))))))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (cond ((di::indirect-value-cell-p o)
+ (values (format nil "~A is a value cell." o)
+ `("Value: " (:value ,(c:value-cell-ref o)))))
+ ((alien::alien-value-p o)
+ (inspect-alien-value o))
+ (t
+ (cmucl-inspect o))))
+
+(defun cmucl-inspect (o)
+ (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
+ (values (format nil "~A~%" text)
+ (if labeledp
+ (loop for (label . value) in parts
+ append (label-value-line label value))
+ (loop for value in parts for i from 0
+ append (label-value-line i value))))))
+
+(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (let ((header (kernel:get-type o)))
+ (cond ((= header vm:function-header-type)
+ (values (format nil "~A is a function." o)
+ (append (label-value-line*
+ ("Self" (kernel:%function-self o))
+ ("Next" (kernel:%function-next o))
+ ("Name" (kernel:%function-name o))
+ ("Arglist" (kernel:%function-arglist o))
+ ("Type" (kernel:%function-type o))
+ ("Code" (kernel:function-code-header o)))
+ (list
+ (with-output-to-string (s)
+ (disassem:disassemble-function o :stream s))))))
+ ((= header vm:closure-header-type)
+ (values (format nil "~A is a closure" o)
+ (append
+ (label-value-line "Function" (kernel:%closure-function o))
+ `("Environment:" (:newline))
+ (loop for i from 0 below (1- (kernel:get-closure-length o))
+ append (label-value-line
+ i (kernel:%closure-index-ref o i))))))
+ ((eval::interpreted-function-p o)
+ (cmucl-inspect o))
+ (t
+ (call-next-method)))))
+
+(defmethod inspect-for-emacs ((o kernel:funcallable-instance)
+ (i backend-inspector))
+ (declare (ignore i))
+ (values
+ (format nil "~A is a funcallable-instance." o)
+ (append (label-value-line*
+ (:function (kernel:%funcallable-instance-function o))
+ (:lexenv (kernel:%funcallable-instance-lexenv o))
+ (:layout (kernel:%funcallable-instance-layout o)))
+ (nth-value 1 (cmucl-inspect o)))))
+
+(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector))
+ (declare (ignore _))
+ (values (format nil "~A is a code data-block." o)
+ (append
+ (label-value-line*
+ ("code-size" (kernel:%code-code-size o))
+ ("entry-points" (kernel:%code-entry-points o))
+ ("debug-info" (kernel:%code-debug-info o))
+ ("trace-table-offset" (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data o)
+ append (label-value-line i (kernel:code-header-ref o i)))
+ `("Code:" (:newline)
+ , (with-output-to-string (s)
+ (cond ((kernel:%code-debug-info o)
+ (disassem:disassemble-code-component o :stream s))
+ (t
+ (disassem:disassemble-memory
+ (disassem::align
+ (+ (logandc2 (kernel:get-lisp-obj-address o)
+ vm:lowtag-mask)
+ (* vm:code-constants-offset vm:word-bytes))
+ (ash 1 vm:lowtag-bits))
+ (ash (kernel:%code-code-size o) vm:word-shift)
+ :stream s))))))))
+
+(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (values (format nil "~A is a fdenf object." o)
+ (label-value-line*
+ ("name" (kernel:fdefn-name o))
+ ("function" (kernel:fdefn-function o))
+ ("raw-addr" (sys:sap-ref-32
+ (sys:int-sap (kernel:get-lisp-obj-address o))
+ (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
+
+(defmethod inspect-for-emacs ((o array) (inspector backend-inspector))
+ inspector
+ (if (typep o 'simple-array)
+ (call-next-method)
+ (values (format nil "~A is an array." o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o))))))
+
+(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector))
+ inspector
+ (values (format nil "~A is a simple-vector." o)
+ (append
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (c::vector-length o)))
+ (loop for i below (length o)
+ append (label-value-line i (aref o i))))))
+
+(defun inspect-alien-record (alien)
+ (values
+ (format nil "~A is an alien value." alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-record-type- kind name fields) type
+ (append
+ (label-value-line*
+ (:sap sap)
+ (:kind kind)
+ (:name name))
+ (loop for field in fields
+ append (let ((slot (alien::alien-record-field-name field)))
+ (label-value-line slot (alien:slot alien slot)))))))))
+
+(defun inspect-alien-pointer (alien)
+ (values
+ (format nil "~A is an alien value." alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (label-value-line*
+ (:sap sap)
+ (:type type)
+ (:to (alien::deref alien))))))
+
+(defun inspect-alien-value (alien)
+ (typecase (alien::alien-value-type alien)
+ (alien::alien-record-type (inspect-alien-record alien))
+ (alien::alien-pointer-type (inspect-alien-pointer alien))
+ (t (cmucl-inspect alien))))
+
+;;;; Profiling
+(defimplementation profile (fname)
+ (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+ (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+ (eval `(profile:unprofile))
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (eval `(profile:report-time)))
+
+(defimplementation profile-reset ()
+ (eval `(profile:reset-time))
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+ (profile:profile-all :package package
+ :callers-p callers
+ #-cmu18e :methods #-cmu18e methods))
+
+
+;;;; Multiprocessing
+
+#+mp
+(progn
+ (defimplementation initialize-multiprocessing (continuation)
+ (mp::init-multi-processing)
+ (mp:make-process continuation :name "swank")
+ ;; Threads magic: this never returns! But top-level becomes
+ ;; available again.
+ (unless mp::*idle-process*
+ (mp::startup-idle-and-top-level-loops)))
+
+ (defimplementation spawn (fn &key name)
+ (mp:make-process fn :name (or name "Anonymous")))
+
+ (defvar *thread-id-counter* 0)
+
+ (defimplementation thread-id (thread)
+ (or (getf (mp:process-property-list thread) 'id)
+ (setf (getf (mp:process-property-list thread) 'id)
+ (incf *thread-id-counter*))))
+
+ (defimplementation find-thread (id)
+ (find id (all-threads)
+ :key (lambda (p) (getf (mp:process-property-list p) 'id))))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (mp:process-whostate thread))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (copy-list mp:*all-processes*))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:destroy-process thread))
+
+ (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ (mutex (mp:make-lock "process mailbox"))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock-held (*mailbox-lock*)
+ (or (getf (mp:process-property-list thread) 'mailbox)
+ (setf (getf (mp:process-property-list thread) 'mailbox)
+ (make-mailbox)))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (mp:with-lock-held (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+ (defimplementation receive ()
+ (let* ((mbox (mailbox mp:*current-process*))
+ (mutex (mailbox.mutex mbox)))
+ (mp:process-wait "receive" #'mailbox.queue mbox)
+ (mp:with-lock-held (mutex)
+ (pop (mailbox.queue mbox)))))
+
+ ) ;; #+mp
+
+
+
+;;;; GC hooks
+;;;
+;;; Display GC messages in the echo area to avoid cluttering the
+;;; normal output.
+;;;
+
+;; this should probably not be here, but where else?
+(defun background-message (message)
+ (funcall (find-symbol (string :background-message) :swank)
+ message))
+
+(defun print-bytes (nbytes &optional stream)
+ "Print the number NBYTES to STREAM in KB, MB, or GB units."
+ (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb))))
+ (multiple-value-bind (power name)
+ (loop for ((p1 n1) (p2 n2)) on names
+ while n2 do
+ (when (<= (expt 2 p1) nbytes (1- (expt 2 p2)))
+ (return (values p1 n1))))
+ (cond (name
+ (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name))
+ (t
+ (format stream "~:D bytes" nbytes))))))
+
+(defconstant gc-generations 6)
+
+#+gencgc
+(defun generation-stats ()
+ "Return a string describing the size distribution among the generations."
+ (let* ((alloc (loop for i below gc-generations
+ collect (lisp::gencgc-stats i)))
+ (sum (coerce (reduce #'+ alloc) 'float)))
+ (format nil "~{~3F~^/~}"
+ (mapcar (lambda (size) (/ size sum))
+ alloc))))
+
+(defvar *gc-start-time* 0)
+
+(defun pre-gc-hook (bytes-in-use)
+ (setq *gc-start-time* (get-internal-real-time))
+ (let ((msg (format nil "[Commencing GC with ~A in use.]"
+ (print-bytes bytes-in-use))))
+ (background-message msg)))
+
+(defun post-gc-hook (bytes-retained bytes-freed trigger)
+ (declare (ignore trigger))
+ (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*)
+ internal-time-units-per-second))
+ (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]"
+ (print-bytes bytes-freed)
+ (print-bytes bytes-retained)
+ #+gencgc(generation-stats)
+ #-gencgc""
+ seconds)))
+ (background-message msg)))
+
+(defun install-gc-hooks ()
+ (setq ext:*gc-notify-before* #'pre-gc-hook)
+ (setq ext:*gc-notify-after* #'post-gc-hook))
+
+(defun remove-gc-hooks ()
+ (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before)
+ (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after))
+
+(defvar *install-gc-hooks* t
+ "If non-nil install GC hooks")
+
+(defimplementation emacs-connected ()
+ (when *install-gc-hooks*
+ (install-gc-hooks)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;;In CMUCL, we have:
+;; (trace <name>)
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
+;; <name> can be a normal name or a (setf name)
+
+(defun tracedp (spec)
+ (member spec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (spec &rest options)
+ (cond ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec ,@options))
+ (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defgeneric)
+ (let ((name (second spec)))
+ (toggle-trace-aux name :methods name)))
+ ((:defmethod)
+ (cond ((fboundp `(method ,@(cdr spec)))
+ (toggle-trace-aux `(method ,(cdr spec))))
+ ;; Man, is this ugly
+ ((fboundp `(pcl::fast-method ,@(cdr spec)))
+ (toggle-trace-aux `(pcl::fast-method ,@(cdr spec))))
+ (t
+ (error 'undefined-function :name (cdr spec)))))
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux (process-fspec callee)
+ :wherein (list (process-fspec caller)))))
+ ;; doesn't work properly
+ ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec)))
+ ))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod)
+ `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+ ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec))))
+ ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec))))))
+ (t
+ fspec)))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-p t args))
+
+;; Local Variables:
+;; pbook-heading-regexp: "^;;;\\(;+\\)"
+;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
+;; End:
Added: branches/bos/thirdparty/emacs/slime/swank-corman.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-corman.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,580 @@
+;;;
+;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
+;;;
+;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw(a)grumblesmurf.org)
+;;;
+;;; License
+;;; =======
+;;; This software is provided 'as-is', without any express or implied
+;;; warranty. In no event will the author be held liable for any damages
+;;; arising from the use of this software.
+;;;
+;;; Permission is granted to anyone to use this software for any purpose,
+;;; including commercial applications, and to alter it and redistribute
+;;; it freely, subject to the following restrictions:
+;;;
+;;; 1. The origin of this software must not be misrepresented; you must
+;;; not claim that you wrote the original software. If you use this
+;;; software in a product, an acknowledgment in the product documentation
+;;; would be appreciated but is not required.
+;;;
+;;; 2. Altered source versions must be plainly marked as such, and must
+;;; not be misrepresented as being the original software.
+;;;
+;;; 3. This notice may not be removed or altered from any source
+;;; distribution.
+;;;
+;;; Notes
+;;; =====
+;;; You will need CCL 2.51, and you will *definitely* need to patch
+;;; CCL with the patches at
+;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
+;;; will blow up in your face. You should also follow the
+;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
+;;;
+;;; The only communication style currently supported is NIL.
+;;;
+;;; Starting CCL inside emacs (with M-x slime) seems to work for me
+;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
+;;; (sometimes it works, other times it hangs on start or hangs when
+;;; initializing WinSock) - starting CCL externally and using M-x
+;;; slime-connect always works fine.
+;;;
+;;; Sometimes CCL gets confused and starts giving you random memory
+;;; access violation errors on startup; if this happens, try redumping
+;;; your image.
+;;;
+;;; What works
+;;; ==========
+;;; * Basic editing and evaluation
+;;; * Arglist display
+;;; * Compilation
+;;; * Loading files
+;;; * apropos/describe
+;;; * Debugger
+;;; * Inspector
+;;;
+;;; TODO
+;;; ====
+;;; * More debugger functionality (missing bits: restart-frame,
+;;; return-from-frame, disassemble-frame, activate-stepping,
+;;; toggle-trace)
+;;; * XREF
+;;; * Profiling
+;;; * More sophisticated communication styles than NIL
+;;;
+
+(in-package :swank-backend)
+
+;;; Pull in various needed bits
+(require :composite-streams)
+(require :sockets)
+(require :winbase)
+(require :lp)
+
+(use-package :gs)
+
+;; MOP stuff
+
+(defclass swank-mop:standard-slot-definition ()
+ ()
+ (:documentation "Dummy class created so that swank.lisp will compile and load."))
+
+(defun named-by-gensym-p (c)
+ (null (symbol-package (class-name c))))
+
+(deftype swank-mop:eql-specializer ()
+ '(satisfies named-by-gensym-p))
+
+(defun swank-mop:eql-specializer-object (specializer)
+ (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
+ (loop (multiple-value-bind (more key value)
+ (next-entry)
+ (unless more (return nil))
+ (when (eq specializer value)
+ (return key))))))
+
+(defun swank-mop:class-finalized-p (class)
+ (declare (ignore class))
+ t)
+
+(defun swank-mop:class-prototype (class)
+ (make-instance class))
+
+(defun swank-mop:specializer-direct-methods (obj)
+ (declare (ignore obj))
+ nil)
+
+(defun swank-mop:generic-function-argument-precedence-order (gf)
+ (generic-function-lambda-list gf))
+
+(defun swank-mop:generic-function-method-combination (gf)
+ (declare (ignore gf))
+ :standard)
+
+(defun swank-mop:generic-function-declarations (gf)
+ (declare (ignore gf))
+ nil)
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (declare (ignore slot))
+ (getf slot :documentation nil))
+
+(defun swank-mop:slot-definition-type (slot)
+ (declare (ignore slot))
+ t)
+
+(import-swank-mop-symbols :cl '(;; classes
+ :standard-slot-definition
+ :eql-specializer
+ :eql-specializer-object
+ ;; standard class readers
+ :class-default-initargs
+ :class-direct-default-initargs
+ :class-finalized-p
+ :class-prototype
+ :specializer-direct-methods
+ ;; gf readers
+ :generic-function-argument-precedence-order
+ :generic-function-declarations
+ :generic-function-method-combination
+ ;; method readers
+ ;; slot readers
+ :slot-definition-documentation
+ :slot-definition-type))
+
+;;;; swank implementations
+
+;;; Debugger
+
+(defvar *stack-trace* nil)
+(defvar *frame-trace* nil)
+
+(defstruct frame
+ name function address debug-info variables)
+
+(defimplementation call-with-debugging-environment (fn)
+ (let* ((real-stack-trace (cl::stack-trace))
+ (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
+ :key #'car)))
+ (*frame-trace*
+ (let* ((db::*debug-level* (1+ db::*debug-level*))
+ (db::*debug-frame-pointer* (db::stash-ebp
+ (ct:create-foreign-ptr)))
+ (db::*debug-max-level* (length real-stack-trace))
+ (db::*debug-min-level* 1))
+ (cdr (member #'cl:invoke-debugger
+ (cons
+ (make-frame :function nil)
+ (loop for i from db::*debug-min-level*
+ upto db::*debug-max-level*
+ until (eq (db::get-frame-function i) cl::*top-level*)
+ collect
+ (make-frame :function (db::get-frame-function i)
+ :address (db::get-frame-address i))))
+ :key #'frame-function)))))
+ (funcall fn)))
+
+(defimplementation compute-backtrace (start end)
+ (subseq *stack-trace* start (min end (length *stack-trace*))))
+
+(defimplementation print-frame (frame stream)
+ (format stream "~S" frame))
+
+(defun get-frame-debug-info (frame)
+ (or (frame-debug-info frame)
+ (setf (frame-debug-info frame)
+ (db::prepare-frame-debug-info (frame-function frame)
+ (frame-address frame)))))
+
+(defimplementation frame-locals (frame-number)
+ (let* ((frame (elt *frame-trace* frame-number))
+ (info (get-frame-debug-info frame)))
+ (let ((var-list
+ (loop for i from 4 below (length info) by 2
+ collect `(list :name ',(svref info i) :id 0
+ :value (db::debug-filter ,(svref info i))))))
+ (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
+ (setf (frame-variables frame) vars)))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (elt *frame-trace* frame-number)))
+ (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
+ (eval form))))
+
+(defimplementation frame-catch-tags (index)
+ (declare (ignore index))
+ nil)
+
+(defimplementation frame-var-value (frame-number var)
+ (let ((vars (frame-variables (elt *frame-trace* frame-number))))
+ (when vars
+ (second (elt vars var)))))
+
+(defimplementation frame-source-location-for-emacs (frame-number)
+ (fspec-location (frame-function (elt *frame-trace* frame-number))))
+
+(defun break (&optional (format-control "Break") &rest format-arguments)
+ (with-simple-restart (continue "Return from BREAK.")
+ (let ();(*debugger-hook* nil))
+ (let ((condition
+ (make-condition 'simple-condition
+ :format-control format-control
+ :format-arguments format-arguments)))
+ ;;(format *debug-io* ";;; User break: ~A~%" condition)
+ (invoke-debugger condition))))
+ nil)
+
+;;; Socket communication
+
+(defimplementation create-socket (host port)
+ (sockets:start-sockets)
+ (sockets:make-server-socket :host host :port port))
+
+(defimplementation local-port (socket)
+ (sockets:socket-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (sockets:make-socket-stream (sockets:accept-socket socket)))
+
+;;; Misc
+
+(defimplementation preferred-communication-style ()
+ nil)
+
+(defimplementation getpid ()
+ ccl:*current-process-id*)
+
+(defimplementation lisp-implementation-type-name ()
+ "cormanlisp")
+
+(defimplementation quit-lisp ()
+ (sockets:stop-sockets)
+ (win32:exitprocess 0))
+
+(defimplementation set-default-directory (directory)
+ (setf (ccl:current-directory) directory)
+ (directory-namestring (setf *default-pathname-defaults*
+ (truename (merge-pathnames directory)))))
+
+(defimplementation default-directory ()
+ (directory-namestring (ccl:current-directory)))
+
+(defimplementation macroexpand-all (form)
+ (ccl:macroexpand-all form))
+
+;;; Documentation
+
+(defun fspec-location (fspec)
+ (when (symbolp fspec)
+ (setq fspec (symbol-function fspec)))
+ (let ((file (ccl::function-source-file fspec)))
+ (if file
+ (handler-case
+ (let ((truename (truename
+ (merge-pathnames file
+ ccl:*cormanlisp-directory*))))
+ (make-location (list :file (namestring truename))
+ (if (ccl::function-source-line fspec)
+ (list :line
+ (1+ (ccl::function-source-line fspec)))
+ (list :function-name (princ-to-string
+ (function-name fspec))))))
+ (error (c) (list :error (princ-to-string c))))
+ (list :error (format nil "No source information available for ~S"
+ fspec)))))
+
+(defimplementation find-definitions (name)
+ (list (list name (fspec-location name))))
+
+(defimplementation arglist (name)
+ (handler-case
+ (cond ((and (symbolp name)
+ (macro-function name))
+ (ccl::macro-lambda-list (symbol-function name)))
+ (t
+ (when (symbolp name)
+ (setq name (symbol-function name)))
+ (if (eq (class-of name) cl::the-class-standard-gf)
+ (generic-function-lambda-list name)
+ (ccl:function-lambda-list name))))
+ (error () :not-available)))
+
+(defimplementation function-name (fn)
+ (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
+ (error () nil)))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:class
+ (describe (find-class symbol)))))
+
+;;; Compiler
+
+(defvar *buffer-name* nil)
+(defvar *buffer-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename* nil)
+
+;; FIXME
+(defimplementation call-with-compilation-hooks (FN)
+ (handler-bind ((error (lambda (c)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition c
+ :severity :warning
+ :message (format nil "~A" c)
+ :location
+ (cond (*buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :position *buffer-position*)))
+ (*compile-filename*
+ (make-location
+ (list :file *compile-filename*)
+ (list :position 1)))
+ (t
+ (list :error "No location"))))))))
+ (funcall fn)))
+
+(defimplementation swank-compile-file (*compile-filename* load-p
+ external-format)
+ (declare (ignore external-format))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil))
+ (compile-file *compile-filename*)
+ (when load-p
+ (load (compile-file-pathname *compile-filename*))))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-position* position)
+ (*buffer-string* string))
+ (funcall (compile nil (read-from-string
+ (format nil "(~S () ~A)" 'lambda string)))))))
+
+;;;; Inspecting
+
+;; Hack to make swank.lisp load, at least
+(defclass file-stream ())
+
+(defclass corman-inspector (backend-inspector)
+ ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'corman-inspector))
+
+(defun comma-separated (list &optional (callback (lambda (v)
+ `(:value ,v))))
+ (butlast (loop for e in list
+ collect (funcall callback e)
+ collect ", ")))
+
+(defmethod inspect-for-emacs ((class standard-class)
+ (inspector backend-inspector))
+ (declare (ignore inspector))
+ (values "A class."
+ `("Name: " (:value ,(class-name class))
+ (:newline)
+ "Super classes: "
+ ,@(comma-separated (swank-mop:class-direct-superclasses class))
+ (:newline)
+ "Direct Slots: "
+ ,@(comma-separated
+ (swank-mop:class-direct-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))
+ (:newline)
+ "Effective Slots: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated
+ (swank-mop:class-slots class)
+ (lambda (slot)
+ `(:value ,slot ,(princ-to-string
+ (swank-mop:slot-definition-name slot)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline)
+ ,@(when (documentation class t)
+ `("Documentation:" (:newline) ,(documentation class t) (:newline)))
+ "Sub classes: "
+ ,@(comma-separated (swank-mop:class-direct-subclasses class)
+ (lambda (sub)
+ `(:value ,sub ,(princ-to-string (class-name sub)))))
+ (:newline)
+ "Precedence List: "
+ ,@(if (swank-mop:class-finalized-p class)
+ (comma-separated (swank-mop:class-precedence-list class)
+ (lambda (class)
+ `(:value ,class ,(princ-to-string (class-name class)))))
+ '("#<N/A (class not finalized)>"))
+ (:newline))))
+
+(defmethod inspect-for-emacs ((slot cons) (inspector backend-inspector))
+ ;; Inspects slot definitions
+ (declare (ignore inspector))
+ (if (eq (car slot) :name)
+ (values "A slot."
+ `("Name: " (:value ,(swank-mop:slot-definition-name slot))
+ (:newline)
+ ,@(when (swank-mop:slot-definition-documentation slot)
+ `("Documentation:" (:newline)
+ (:value ,(swank-mop:slot-definition-documentation slot))
+ (:newline)))
+ "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
+ "Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
+ `(:value ,(swank-mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
+ (:newline)))
+ (call-next-method)))
+
+(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)
+ inspector)
+ (declare (ignore inspector))
+ (values (if (wild-pathname-p pathname)
+ "A wild pathname."
+ "A pathname.")
+ (append (label-value-line*
+ ("Namestring" (namestring pathname))
+ ("Host" (pathname-host pathname))
+ ("Device" (pathname-device pathname))
+ ("Directory" (pathname-directory pathname))
+ ("Name" (pathname-name pathname))
+ ("Type" (pathname-type pathname))
+ ("Version" (pathname-version pathname)))
+ (unless (or (wild-pathname-p pathname)
+ (not (probe-file pathname)))
+ (label-value-line "Truename" (truename pathname))))))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (cond ((cl::structurep o) (inspect-structure o))
+ (t (call-next-method))))
+
+(defun inspect-structure (o)
+ (values
+ (format nil "~A is a structure" o)
+ (let* ((template (cl::uref o 1))
+ (num-slots (cl::struct-template-num-slots template)))
+ (cond ((symbolp template)
+ (loop for i below num-slots
+ append (label-value-line i (cl::uref o (+ 2 i)))))
+ (t
+ (loop for i below num-slots
+ append (label-value-line (elt template (+ 6 (* i 5)))
+ (cl::uref o (+ 2 i)))))))))
+
+
+;;; Threads
+
+(require 'threads)
+
+(defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (lock (make-instance 'threads:critical-section))
+ (queue '() :type list))
+
+(defvar *mailbox-lock* (make-instance 'threads:critical-section))
+(defvar *mailboxes* (list))
+
+(defmacro with-lock (lock &body body)
+ `(threads:with-synchronization (threads:cs ,lock)
+ ,@body))
+
+(defimplementation spawn (fun &key name)
+ (declare (ignore name))
+ (th:create-thread
+ (lambda ()
+ (handler-bind ((serious-condition #'invoke-debugger))
+ (unwind-protect (funcall fun)
+ (with-lock *mailbox-lock*
+ (setq *mailboxes* (remove cormanlisp:*current-thread-id*
+ *mailboxes* :key #'mailbox.thread))))))))
+
+(defimplementation thread-id (thread)
+ thread)
+
+(defimplementation find-thread (thread)
+ (if (thread-alive-p thread)
+ thread))
+
+(defimplementation thread-alive-p (thread)
+ (if (threads:thread-handle thread) t nil))
+
+(defimplementation current-thread ()
+ cormanlisp:*current-thread-id*)
+
+;; XXX implement it
+(defimplementation all-threads ()
+ '())
+
+;; XXX something here is broken
+(defimplementation kill-thread (thread)
+ (threads:terminate-thread thread 'killed))
+
+(defun mailbox (thread)
+ (with-lock *mailbox-lock*
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+(defimplementation send (thread message)
+ (let ((mbox (mailbox thread)))
+ (with-lock (mailbox.lock mbox)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))
+
+(defimplementation receive ()
+ (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
+ (loop
+ (with-lock (mailbox.lock mbox)
+ (when (mailbox.queue mbox)
+ (return (pop (mailbox.queue mbox)))))
+ (sleep 0.1))))
+
+
+;;; This is probably not good, but it WFM
+(in-package :common-lisp)
+
+(defvar *old-documentation* #'documentation)
+(defun documentation (thing &optional (type 'function))
+ (if (symbolp thing)
+ (funcall *old-documentation* thing type)
+ (values)))
+
+(defmethod print-object ((restart restart) stream)
+ (if (or *print-escape*
+ *print-readably*)
+ (print-unreadable-object (restart stream :type t :identity t)
+ (princ (restart-name restart) stream))
+ (when (functionp (restart-report-function restart))
+ (funcall (restart-report-function restart) stream))))
Added: branches/bos/thirdparty/emacs/slime/swank-ecl.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-ecl.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,416 @@
+;;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-ecl.lisp --- SLIME backend for ECL.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;;; Administrivia
+
+(in-package :swank-backend)
+
+(import-from :ext *gray-stream-symbols* :swank-backend)
+
+(swank-backend::import-swank-mop-symbols :clos
+ '(:eql-specializer
+ :eql-specializer-object
+ :generic-function-declarations
+ :specializer-direct-methods
+ :compute-applicable-methods-using-classes))
+
+
+;;;; TCP Server
+
+(require 'sockets)
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+ (sb-bsd-sockets:socket-listen socket 5)
+ socket))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+ (sb-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket
+ &key external-format
+ buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (make-socket-io-stream (accept 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 ()))))
+
+(defimplementation preferred-communication-style ()
+ (values nil))
+
+
+;;;; Unix signals
+
+(defimplementation getpid ()
+ (si:getpid))
+
+#+nil
+(defimplementation set-default-directory (directory)
+ (ext::chdir (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (ext::getcwd))
+ (default-directory))
+
+#+nil
+(defimplementation default-directory ()
+ (namestring (ext:getcwd)))
+
+(defimplementation quit-lisp ()
+ (ext:quit))
+
+
+;;;; Compilation
+
+(defvar *buffer-name* nil)
+(defvar *buffer-start-position*)
+(defvar *buffer-string*)
+(defvar *compile-filename*)
+
+(defun signal-compiler-condition (&rest args)
+ (signal (apply #'make-condition 'compiler-condition args)))
+
+(defun handle-compiler-warning (condition)
+ (signal-compiler-condition
+ :original-condition condition
+ :message (format nil "~A" condition)
+ :severity :warning
+ :location
+ (if *buffer-name*
+ (make-location (list :buffer *buffer-name*)
+ (list :position *buffer-start-position*))
+ ;; ;; compiler::*current-form*
+ ;; (if compiler::*current-function*
+ ;; (make-location (list :file *compile-filename*)
+ ;; (list :function-name
+ ;; (symbol-name
+ ;; (slot-value compiler::*current-function*
+ ;; 'compiler::name))))
+ (list :error "No location found.")
+ ;; )
+ )))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((warning #'handle-compiler-warning))
+ (funcall function)))
+
+(defimplementation swank-compile-file (*compile-filename* load-p
+ external-format)
+ (declare (ignore external-format))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil))
+ (multiple-value-bind (fn warn fail)
+ (compile-file *compile-filename*)
+ (when load-p (unless fail (load fn)))))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-string* string))
+ (with-input-from-string (s string)
+ (compile-from-stream s :load t)))))
+
+(defun compile-from-stream (stream &rest args)
+ (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
+ (with-open-file (s file :direction :output :if-exists :overwrite)
+ (do ((line (read-line stream nil) (read-line stream nil)))
+ ((not line))
+ (write-line line s)))
+ (unwind-protect
+ (apply #'compile-file file args)
+ (delete-file file))))
+
+
+;;;; Documentation
+
+(defimplementation arglist (name)
+ (or (functionp name) (setf name (symbol-function name)))
+ (if (functionp name)
+ (typecase name
+ (generic-function
+ (clos::generic-function-lambda-list name))
+ (compiled-function
+ ; most of the compiled functions have an Args: line in their docs
+ (with-input-from-string (s (or
+ (si::get-documentation
+ (si:compiled-function-name name) 'function)
+ ""))
+ (do ((line (read-line s nil) (read-line s nil)))
+ ((not line) :not-available)
+ (ignore-errors
+ (if (string= (subseq line 0 6) "Args: ")
+ (return-from nil
+ (read-from-string (subseq line 6))))))))
+ ;
+ (function
+ (let ((fle (function-lambda-expression name)))
+ (case (car fle)
+ (si:lambda-block (caddr fle))
+ (t :not-available)))))
+ :not-available))
+
+(defimplementation function-name (f)
+ (si:compiled-function-name f))
+
+(defimplementation macroexpand-all (form)
+ ;;; FIXME! This is not the same as a recursive macroexpansion!
+ (macroexpand form))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (dolist (type '(:VARIABLE :FUNCTION :CLASS))
+ (let ((doc (describe-definition symbol type)))
+ (when doc
+ (setf result (list* type doc result)))))
+ result))
+
+(defimplementation describe-definition (name type)
+ (case type
+ (:variable (documentation name 'variable))
+ (:function (documentation name 'function))
+ (:class (documentation name 'class))
+ (t nil)))
+
+;;; Debugging
+
+(import
+ '(si::*ihs-top*
+ si::*ihs-current*
+ si::*ihs-base*
+ si::*frs-base*
+ si::*frs-top*
+ si::*tpl-commands*
+ si::*tpl-level*
+ si::frs-top
+ si::ihs-top
+ si::sch-frs-base
+ si::set-break-env
+ si::set-current-ihs
+ si::tpl-commands))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* ((*tpl-commands* si::tpl-commands)
+ (*ihs-top* (ihs-top 'call-with-debugging-environment))
+ (*ihs-current* *ihs-top*)
+ (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
+ (*frs-top* (frs-top))
+ (*read-suppress* nil)
+ (*tpl-level* (1+ *tpl-level*)))
+ (set-break-env)
+ (set-current-ihs)
+ (funcall debugger-loop-fn)))
+
+;; (defimplementation call-with-debugger-hook (hook fun)
+;; (let ((*debugger-hook* hook))
+;; (funcall fun)))
+
+(defun nth-frame (n)
+ (cond ((>= n *ihs-top* ) nil)
+ (t (- *ihs-top* n))))
+
+(defimplementation compute-backtrace (start end)
+ (loop for i from start below end
+ for f = (nth-frame i)
+ while f
+ collect f))
+
+(defimplementation print-frame (frame stream)
+ (format stream "~A" (si::ihs-fname frame)))
+
+;;;; Inspector
+
+(defclass ecl-inspector (inspector)
+ ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'ecl-inspector))
+
+;;;; Definitions
+
+(defimplementation find-definitions (name) nil)
+
+;;;; Threads
+
+#+threads
+(progn
+ (defvar *thread-id-counter* 0)
+
+ (defvar *thread-id-counter-lock*
+ (mp:make-lock :name "thread id counter lock"))
+
+ (defun next-thread-id ()
+ (mp:with-lock (*thread-id-counter-lock*)
+ (incf *thread-id-counter*)))
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ (defvar *thread-id-map-lock*
+ (mp:make-lock :name "thread id map lock"))
+
+ ; ecl doesn't have weak pointers
+ (defimplementation spawn (fn &key name)
+ (let ((thread (mp:make-process :name name))
+ (id (next-thread-id)))
+ (mp:process-preset
+ thread
+ #'(lambda ()
+ (unwind-protect
+ (mp:with-lock (*thread-id-map-lock*)
+ (setf (gethash id *thread-id-map*) thread))
+ (funcall fn)
+ (mp:with-lock (*thread-id-map-lock*)
+ (remhash id *thread-id-map*)))))
+ (mp:process-enable thread)))
+
+ (defimplementation thread-id (thread)
+ (block thread-id
+ (mp:with-lock (*thread-id-map-lock*)
+ (loop for id being the hash-key in *thread-id-map*
+ using (hash-value thread-pointer)
+ do (if (eq thread thread-pointer)
+ (return-from thread-id id))))))
+
+ (defimplementation find-thread (id)
+ (mp:with-lock (*thread-id-map-lock*)
+ (gethash id *thread-id-map*)))
+
+ (defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+ (defimplementation thread-status (thread)
+ (if (mp:process-active-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+ (defimplementation make-lock (&key name)
+ (mp:make-lock :name name))
+
+ (defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (mp:with-lock (lock) (funcall function)))
+
+ (defimplementation make-recursive-lock (&key name)
+ (mp:make-lock :name name))
+
+ (defimplementation call-with-recursive-lock-held (lock function)
+ (declare (type function function))
+ (mp:with-lock (lock) (funcall function)))
+
+ (defimplementation current-thread ()
+ mp:*current-process*)
+
+ (defimplementation all-threads ()
+ (mp:all-processes))
+
+ (defimplementation interrupt-thread (thread fn)
+ (mp:interrupt-process thread fn))
+
+ (defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+ (defimplementation thread-alive-p (thread)
+ (mp:process-active-p thread))
+
+ (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ (mutex (mp:make-lock :name "process mailbox"))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (mp:with-lock (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (mp:interrupt-process
+ thread
+ (lambda ()
+ (mp:with-lock (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message))))))))
+
+ (defimplementation receive ()
+ (block got-mail
+ (let* ((mbox (mailbox mp:*current-process*))
+ (mutex (mailbox.mutex mbox)))
+ (loop
+ (mp:with-lock (mutex)
+ (if (mailbox.queue mbox)
+ (return-from got-mail (pop (mailbox.queue mbox)))))
+ ;interrupt-process will halt this if it takes longer than 1sec
+ (sleep 1)))))
+
+ ;; Auto-flush streams
+ (defvar *auto-flush-interval* 0.15
+ "How often to flush interactive streams. This valu is passed
+ directly to cl:sleep.")
+
+ (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
+
+ (defvar *auto-flush-thread* nil)
+
+ (defvar *auto-flush-streams* '())
+
+ (defimplementation make-stream-interactive (stream)
+ (call-with-recursive-lock-held
+ *auto-flush-lock*
+ (lambda ()
+ (pushnew stream *auto-flush-streams*)
+ (unless *auto-flush-thread*
+ (setq *auto-flush-thread*
+ (spawn #'flush-streams
+ :name "auto-flush-thread"))))))
+
+ (defmethod stream-finish-output ((stream stream))
+ (finish-output stream))
+
+ (defun flush-streams ()
+ (loop
+ (call-with-recursive-lock-held
+ *auto-flush-lock*
+ (lambda ()
+ (setq *auto-flush-streams*
+ (remove-if (lambda (x)
+ (not (and (open-stream-p x)
+ (output-stream-p x))))
+ *auto-flush-streams*))
+ (mapc #'stream-finish-output *auto-flush-streams*)))
+ (sleep *auto-flush-interval*)))
+
+ )
+
Added: branches/bos/thirdparty/emacs/slime/swank-gray.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-gray.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,168 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; swank-gray.lisp --- Gray stream based IO redirection.
+;;;
+;;; Created 2003
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package :swank-backend)
+
+(defclass slime-output-stream (fundamental-character-output-stream)
+ ((output-fn :initarg :output-fn)
+ (buffer :initform (make-string 8000))
+ (fill-pointer :initform 0)
+ (column :initform 0)
+ (last-flush-time :initform (get-internal-real-time))
+ (lock :initform (make-recursive-lock :name "buffer write lock"))))
+
+(defmethod stream-write-char ((stream slime-output-stream) char)
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (buffer fill-pointer column) stream
+ (setf (schar buffer fill-pointer) char)
+ (incf fill-pointer)
+ (incf column)
+ (when (char= #\newline char)
+ (setf column 0)
+ (force-output stream))
+ (when (= fill-pointer (length buffer))
+ (finish-output stream)))))
+ char)
+
+(defmethod stream-line-column ((stream slime-output-stream))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (slot-value stream 'column))))
+
+(defmethod stream-line-length ((stream slime-output-stream))
+ 75)
+
+(defmethod stream-finish-output ((stream slime-output-stream))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (buffer fill-pointer output-fn last-flush-time) stream
+ (let ((end fill-pointer))
+ (unless (zerop end)
+ (funcall output-fn (subseq buffer 0 end))
+ (setf fill-pointer 0)))
+ (setf last-flush-time (get-internal-real-time)))))
+ nil)
+
+(defmethod stream-force-output ((stream slime-output-stream))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (last-flush-time fill-pointer) stream
+ (let ((now (get-internal-real-time)))
+ (when (> (/ (- now last-flush-time)
+ (coerce internal-time-units-per-second 'double-float))
+ 0.2)
+ (finish-output stream))))))
+ nil)
+
+(defmethod stream-fresh-line ((stream slime-output-stream))
+ (call-with-recursive-lock-held
+ (slot-value stream 'lock)
+ (lambda ()
+ (with-slots (column) stream
+ (cond ((zerop column) nil)
+ (t (terpri stream) t))))))
+
+(defclass slime-input-stream (fundamental-character-input-stream)
+ ((output-stream :initarg :output-stream)
+ (input-fn :initarg :input-fn)
+ (buffer :initform "") (index :initform 0)
+ (lock :initform (make-lock :name "buffer read lock"))))
+
+(defmethod stream-read-char ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index output-stream input-fn) s
+ (when (= index (length buffer))
+ (when output-stream
+ (finish-output output-stream))
+ (let ((string (funcall input-fn)))
+ (cond ((zerop (length string))
+ (return-from stream-read-char :eof))
+ (t
+ (setf buffer string)
+ (setf index 0)))))
+ (assert (plusp (length buffer)))
+ (prog1 (aref buffer index) (incf index))))))
+
+(defmethod stream-listen ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (< index (length buffer))))))
+
+(defmethod stream-unread-char ((s slime-input-stream) char)
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (decf index)
+ (cond ((eql (aref buffer index) char)
+ (setf (aref buffer index) char))
+ (t
+ (warn "stream-unread-char: ignoring ~S (expected ~S)"
+ char (aref buffer index)))))))
+ nil)
+
+(defmethod stream-clear-input ((s slime-input-stream))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (with-slots (buffer index) s
+ (setf buffer ""
+ index 0))))
+ nil)
+
+(defmethod stream-line-column ((s slime-input-stream))
+ nil)
+
+(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))
+ (call-with-lock-held
+ (slot-value s 'lock)
+ (lambda ()
+ (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))))
+
+
+;;;
+(defimplementation 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
Added: branches/bos/thirdparty/emacs/slime/swank-lispworks.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-lispworks.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,791 @@
+;;; -*- indent-tabs-mode: nil -*-
+;;;
+;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
+;;;
+;;; Created 2003, Helmut Eller
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package :swank-backend)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require "comm")
+ (import-from :stream *gray-stream-symbols* :swank-backend))
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation
+ :eql-specializer
+ :eql-specializer-object
+ :compute-applicable-methods-using-classes))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+(defun swank-mop:compute-applicable-methods-using-classes (gf classes)
+ (clos::compute-applicable-methods-from-classes gf classes))
+
+;; lispworks doesn't have the eql-specializer class, it represents
+;; them as a list of `(EQL ,OBJECT)
+(deftype swank-mop:eql-specializer () 'cons)
+
+(defun swank-mop:eql-specializer-object (eql-spec)
+ (second eql-spec))
+
+(when (fboundp 'dspec::define-dspec-alias)
+ (dspec::define-dspec-alias defimplementation (name args &rest body)
+ `(defmethod ,name ,args ,@body)))
+
+;;; TCP server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defun socket-fd (socket)
+ (etypecase socket
+ (fixnum socket)
+ (comm:socket-stream (comm:socket-stream-socket socket))))
+
+(defimplementation create-socket (host port)
+ (multiple-value-bind (socket where errno)
+ #-(or lispworks4.1 (and macosx lispworks4.3))
+ (comm::create-tcp-socket-for-service port :address host)
+ #+(or lispworks4.1 (and macosx lispworks4.3))
+ (comm::create-tcp-socket-for-service port)
+ (cond (socket socket)
+ (t (error 'network-error
+ :format-control "~A failed: ~A (~D)"
+ :format-arguments (list where
+ (list #+unix (lw:get-unix-error errno))
+ errno))))))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (comm:get-socket-address (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (comm::close-socket (socket-fd socket)))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (declare (ignore buffering timeout external-format))
+ (let* ((fd (comm::get-fd-from-socket socket)))
+ (assert (/= fd -1))
+ (make-instance 'comm:socket-stream :socket fd :direction :io
+ :element-type 'base-char)))
+
+(defun set-sigint-handler ()
+ ;; Set SIGINT handler on Swank request handler thread.
+ #-win32
+ (sys::set-signal-handler +sigint+
+ (make-sigint-handler mp:*current-process*)))
+
+;;; Coding Systems
+
+(defvar *external-format-to-coding-system*
+ '(((:latin-1 :eol-style :lf)
+ "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
+ ((:latin-1)
+ "latin-1" "iso-latin-1" "iso-8859-1")
+ ((:utf-8) "utf-8")
+ ((:utf-8 :eol-style :lf) "utf-8-unix")
+ ((:euc-jp) "euc-jp")
+ ((:euc-jp :eol-style :lf) "euc-jp-unix")
+ ((:ascii) "us-ascii")
+ ((:ascii :eol-style :lf) "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+;;; Unix signals
+
+(defun sigint-handler ()
+ (with-simple-restart (continue "Continue from SIGINT handler.")
+ (invoke-debugger "SIGINT")))
+
+(defun make-sigint-handler (process)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (mp:process-interrupt process #'sigint-handler)))
+
+(defimplementation call-without-interrupts (fn)
+ (lw:without-interrupts (funcall fn)))
+
+(defimplementation getpid ()
+ #+win32 (win32:get-current-process-id)
+ #-win32 (system::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "lispworks")
+
+(defimplementation set-default-directory (directory)
+ (namestring (hcl:change-directory directory)))
+
+;;;; Documentation
+
+(defimplementation arglist (symbol-or-function)
+ (let ((arglist (lw:function-lambda-list symbol-or-function)))
+ (etypecase arglist
+ ((member :dont-know)
+ :not-available)
+ (list
+ arglist))))
+
+(defimplementation function-name (function)
+ (nth-value 2 (function-lambda-expression function)))
+
+(defimplementation macroexpand-all (form)
+ (walker:walk-form form))
+
+(defun generic-function-p (object)
+ (typep object 'generic-function))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ "Return a plist describing SYMBOL.
+Return NIL if the symbol is unbound."
+ (let ((result '()))
+ (labels ((first-line (string)
+ (let ((pos (position #\newline string)))
+ (if (null pos) string (subseq string 0 pos))))
+ (doc (kind &optional (sym symbol))
+ (let ((string (documentation sym kind)))
+ (if string
+ (first-line string)
+ :not-documented)))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :generic-function (if (and (fboundp symbol)
+ (generic-function-p (fdefinition symbol)))
+ (doc 'function)))
+ (maybe-push
+ :function (if (and (fboundp symbol)
+ (not (generic-function-p (fdefinition symbol))))
+ (doc 'function)))
+ (maybe-push
+ :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
+ (if (fboundp setf-name)
+ (doc 'setf))))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ result)))
+
+(defimplementation describe-definition (symbol type)
+ (ecase type
+ (:variable (describe-symbol symbol))
+ (:class (describe (find-class symbol)))
+ ((:function :generic-function) (describe-function symbol))
+ (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
+
+(defun describe-function (symbol)
+ (cond ((fboundp symbol)
+ (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
+ (string-downcase symbol)
+ (mapcar #'string-upcase
+ (lispworks:function-lambda-list symbol))
+ (documentation symbol 'function))
+ (describe (fdefinition symbol)))
+ (t (format t "~S is not fbound" symbol))))
+
+(defun describe-symbol (sym)
+ (format t "~A is a symbol in package ~A." sym (symbol-package sym))
+ (when (boundp sym)
+ (format t "~%~%Value: ~A" (symbol-value sym)))
+ (let ((doc (documentation sym 'variable)))
+ (when doc
+ (format t "~%~%Variable documentation:~%~A" doc)))
+ (when (fboundp sym)
+ (describe-function sym)))
+
+;;; Debugging
+
+(defclass slime-env (env:environment)
+ ((debugger-hook :initarg :debugger-hoook)))
+
+(defun slime-env (hook io-bindings)
+ (make-instance 'slime-env :name "SLIME Environment"
+ :io-bindings io-bindings
+ :debugger-hoook hook))
+
+(defmethod env-internals:environment-display-notifier
+ ((env slime-env) &key restarts condition)
+ (declare (ignore restarts))
+ (funcall (slot-value env 'debugger-hook) condition *debugger-hook*))
+
+(defmethod env-internals:environment-display-debugger ((env slime-env))
+ *debug-io*)
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((*debugger-hook* hook))
+ (env:with-environment ((slime-env hook '()))
+ (funcall fun))))
+
+(defvar *sldb-top-frame*)
+
+(defun interesting-frame-p (frame)
+ (cond ((or (dbg::call-frame-p frame)
+ (dbg::derived-call-frame-p frame)
+ (dbg::foreign-frame-p frame)
+ (dbg::interpreted-call-frame-p frame))
+ t)
+ ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
+ ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
+ ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
+ ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
+ ((dbg::open-frame-p frame) dbg:*print-open-frames*)
+ (t nil)))
+
+(defun nth-next-frame (frame n)
+ "Unwind FRAME N times."
+ (do ((frame frame (dbg::frame-next frame))
+ (i n (if (interesting-frame-p frame) (1- i) i)))
+ ((or (not frame)
+ (and (interesting-frame-p frame) (zerop i)))
+ frame)))
+
+(defun nth-frame (index)
+ (nth-next-frame *sldb-top-frame* index))
+
+(defun find-top-frame ()
+ "Return the most suitable top-frame for the debugger."
+ (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
+ (nth-next-frame frame 1)))
+ ((or (null frame) ; no frame found!
+ (and (dbg::call-frame-p frame)
+ (eq (dbg::call-frame-function-name frame)
+ 'invoke-debugger)))
+ (nth-next-frame frame 1)))
+ ;; if we can't find a invoke-debugger frame, take any old frame at the top
+ (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
+
+(defimplementation call-with-debugging-environment (fn)
+ (dbg::with-debugger-stack ()
+ (let ((*sldb-top-frame* (find-top-frame)))
+ (funcall fn))))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum))
+ (backtrace '()))
+ (do ((frame (nth-frame start) (dbg::frame-next frame))
+ (i start))
+ ((or (not frame) (= i end)) (nreverse backtrace))
+ (when (interesting-frame-p frame)
+ (incf i)
+ (push frame backtrace)))))
+
+(defun frame-actual-args (frame)
+ (let ((*break-on-signals* nil))
+ (mapcar (lambda (arg)
+ (case arg
+ ((&rest &optional &key) arg)
+ (t
+ (handler-case (dbg::dbg-eval arg frame)
+ (error (e) (format nil "<~A>" arg))))))
+ (dbg::call-frame-arglist frame))))
+
+(defimplementation print-frame (frame stream)
+ (cond ((dbg::call-frame-p frame)
+ (format stream "~S ~S"
+ (dbg::call-frame-function-name frame)
+ (frame-actual-args frame)))
+ (t (princ frame stream))))
+
+(defun frame-vars (frame)
+ (first (dbg::frame-locals-format-list frame #'list 75 0)))
+
+(defimplementation frame-locals (n)
+ (let ((frame (nth-frame n)))
+ (if (dbg::call-frame-p frame)
+ (mapcar (lambda (var)
+ (destructuring-bind (name value symbol location) var
+ (declare (ignore name location))
+ (list :name symbol :id 0
+ :value value)))
+ (frame-vars frame)))))
+
+(defimplementation frame-var-value (frame var)
+ (let ((frame (nth-frame frame)))
+ (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
+ (declare (ignore _n _s _l))
+ value)))
+
+(defimplementation frame-catch-tags (index)
+ (declare (ignore index))
+ nil)
+
+(defimplementation frame-source-location-for-emacs (frame)
+ (let ((frame (nth-frame frame))
+ (callee (if (plusp frame) (nth-frame (1- frame)))))
+ (if (dbg::call-frame-p frame)
+ (let ((dspec (dbg::call-frame-function-name frame))
+ (cname (and (dbg::call-frame-p callee)
+ (dbg::call-frame-function-name callee))))
+ (if dspec
+ (frame-location dspec cname))))))
+
+(defimplementation eval-in-frame (form frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (dbg::dbg-eval form frame)))
+
+(defimplementation return-from-frame (frame-number form)
+ (let* ((frame (nth-frame frame-number))
+ (return-frame (dbg::find-frame-for-return frame)))
+ (dbg::dbg-return-from-call-frame frame form return-frame
+ dbg::*debugger-stack*)))
+
+(defimplementation restart-frame (frame-number)
+ (let ((frame (nth-frame frame-number)))
+ (dbg::restart-frame frame :same-args t)))
+
+;;; Definition finding
+
+(defun frame-location (dspec callee-name)
+ (let ((infos (dspec:find-dspec-locations dspec)))
+ (cond (infos
+ (destructuring-bind ((rdspec location) &rest _) infos
+ (declare (ignore _))
+ (let ((name (and callee-name (symbolp callee-name)
+ (string callee-name))))
+ (make-dspec-location rdspec location
+ `(:call-site ,name)))))
+ (t
+ (list :error (format nil "Source location not available for: ~S"
+ dspec))))))
+
+(defimplementation find-definitions (name)
+ (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
+ (loop for (dspec location) in locations
+ collect (list dspec (make-dspec-location dspec location)))))
+
+
+;;; Compilation
+
+(defmacro with-swank-compilation-unit ((location &rest options) &body body)
+ (lw:rebinding (location)
+ `(let ((compiler::*error-database* '()))
+ (with-compilation-unit ,options
+ ,@body
+ (signal-error-data-base compiler::*error-database* ,location)
+ (signal-undefined-functions compiler::*unknown-functions* ,location)))))
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (with-swank-compilation-unit (filename)
+ (compile-file filename :load load-p :external-format external-format)))
+
+(defvar *within-call-with-compilation-hooks* nil
+ "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
+
+(defvar *undefined-functions-hash* nil
+ "Hash table to map info about undefined functions to pathnames.")
+
+(lw:defadvice (compile-file compile-file-and-collect-notes :around)
+ (pathname &rest rest)
+ (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
+ (when *within-call-with-compilation-hooks*
+ (maphash (lambda (unfun dspecs)
+ (dolist (dspec dspecs)
+ (let ((unfun-info (list unfun dspec)))
+ (unless (gethash unfun-info *undefined-functions-hash*)
+ (setf (gethash unfun-info *undefined-functions-hash*)
+ pathname)))))
+ compiler::*unknown-functions*))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((compiler::*error-database* '())
+ (*undefined-functions-hash* (make-hash-table :test 'equal))
+ (*within-call-with-compilation-hooks* t))
+ (with-compilation-unit ()
+ (prog1 (funcall function)
+ (signal-error-data-base compiler::*error-database*)
+ (signal-undefined-functions compiler::*unknown-functions*)))))
+
+(defun map-error-database (database fn)
+ (loop for (filename . defs) in database do
+ (loop for (dspec . conditions) in defs do
+ (dolist (c conditions)
+ (funcall fn filename dspec c)))))
+
+(defun lispworks-severity (condition)
+ (cond ((not condition) :warning)
+ (t (etypecase condition
+ (error :error)
+ (style-warning :warning)
+ (warning :warning)))))
+
+(defun signal-compiler-condition (message location condition)
+ (check-type message string)
+ (signal
+ (make-instance 'compiler-condition :message message
+ :severity (lispworks-severity condition)
+ :location location
+ :original-condition condition)))
+
+(defun compile-from-temp-file (string filename)
+ (unwind-protect
+ (progn
+ (with-open-file (s filename :direction :output :if-exists :supersede)
+ (write-string string s)
+ (finish-output s))
+ (let ((binary-filename (compile-file filename :load t)))
+ (when binary-filename
+ (delete-file binary-filename))))
+ (delete-file filename)))
+
+(defun dspec-buffer-position (dspec offset)
+ (etypecase dspec
+ (cons (let ((name (dspec:dspec-primary-name dspec)))
+ (typecase name
+ ((or symbol string)
+ (list :function-name (string name)))
+ (t (list :position offset)))))
+ (null (list :position offset))
+ (symbol (list :function-name (string dspec)))))
+
+(defmacro with-fairly-standard-io-syntax (&body body)
+ "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
+ (let ((package (gensym))
+ (readtable (gensym)))
+ `(let ((,package *package*)
+ (,readtable *readtable*))
+ (with-standard-io-syntax
+ (let ((*package* ,package)
+ (*readtable* ,readtable))
+ ,@body)))))
+
+#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
+(defun dspec-stream-position (stream dspec)
+ (with-fairly-standard-io-syntax
+ (loop (let* ((pos (file-position stream))
+ (form (read stream nil '#1=#:eof)))
+ (when (eq form '#1#)
+ (return nil))
+ (labels ((check-dspec (form)
+ (when (consp form)
+ (let ((operator (car form)))
+ (case operator
+ ((progn)
+ (mapcar #'check-dspec
+ (cdr form)))
+ ((eval-when locally macrolet symbol-macrolet)
+ (mapcar #'check-dspec
+ (cddr form)))
+ ((in-package)
+ (let ((package (find-package (second form))))
+ (when package
+ (setq *package* package))))
+ (otherwise
+ (let ((form-dspec (dspec:parse-form-dspec form)))
+ (when (dspec:dspec-equal dspec form-dspec)
+ (return pos)))))))))
+ (check-dspec form))))))
+
+(defun dspec-file-position (file dspec)
+ (let* ((*compile-file-pathname* (pathname file))
+ (*compile-file-truename* (truename *compile-file-pathname*))
+ (*load-pathname* *compile-file-pathname*)
+ (*load-truename* *compile-file-truename*))
+ (with-open-file (stream file)
+ (let ((pos
+ #-(or lispworks4.1 lispworks4.2)
+ (dspec-stream-position stream dspec)))
+ (if pos
+ (list :position (1+ pos) t)
+ (dspec-buffer-position dspec 1))))))
+
+(defun emacs-buffer-location-p (location)
+ (and (consp location)
+ (eq (car location) :emacs-buffer)))
+
+(defun make-dspec-location (dspec location &optional hints)
+ (etypecase location
+ ((or pathname string)
+ (multiple-value-bind (file err)
+ (ignore-errors (namestring (truename location)))
+ (if err
+ (list :error (princ-to-string err))
+ (make-location `(:file ,file)
+ (dspec-file-position file dspec)
+ hints))))
+ (symbol
+ `(:error ,(format nil "Cannot resolve location: ~S" location)))
+ ((satisfies emacs-buffer-location-p)
+ (destructuring-bind (_ buffer offset string) location
+ (declare (ignore _ string))
+ (make-location `(:buffer ,buffer)
+ (dspec-buffer-position dspec offset)
+ hints)))))
+
+(defun make-dspec-progenitor-location (dspec location)
+ (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
+ (make-dspec-location
+ (if canon-dspec
+ (if (dspec:local-dspec-p canon-dspec)
+ (dspec:dspec-progenitor canon-dspec)
+ canon-dspec)
+ nil)
+ location)))
+
+(defun signal-error-data-base (database &optional location)
+ (map-error-database
+ database
+ (lambda (filename dspec condition)
+ (signal-compiler-condition
+ (format nil "~A" condition)
+ (make-dspec-progenitor-location dspec (or location filename))
+ condition))))
+
+(defun unmangle-unfun (symbol)
+ "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
+function names like \(SETF GET)."
+ (cond ((sys::setf-symbol-p symbol)
+ (sys::setf-pair-from-underlying-name symbol))
+ (t symbol)))
+
+(defun signal-undefined-functions (htab &optional filename)
+ (maphash (lambda (unfun dspecs)
+ (dolist (dspec dspecs)
+ (signal-compiler-condition
+ (format nil "Undefined function ~A" (unmangle-unfun unfun))
+ (make-dspec-progenitor-location dspec
+ (or filename
+ (gethash (list unfun dspec)
+ *undefined-functions-hash*)))
+ nil)))
+ htab))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (assert buffer)
+ (assert position)
+ (let* ((location (list :emacs-buffer buffer position string))
+ (tmpname (hcl:make-temp-file nil "lisp")))
+ (with-swank-compilation-unit (location)
+ (compile-from-temp-file
+ (with-output-to-string (s)
+ (let ((*print-radix* t))
+ (print `(eval-when (:compile-toplevel)
+ (setq dspec::*location* (list ,@location)))
+ s))
+ (write-string string s))
+ tmpname))))
+
+;;; xref
+
+(defmacro defxref (name function)
+ `(defimplementation ,name (name)
+ (xref-results (,function name))))
+
+(defxref who-calls hcl:who-calls)
+(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
+(defxref calls-who hcl:calls-who)
+(defxref list-callers list-callers-internal)
+;; (defxref list-callees list-callees-internal)
+
+(defun list-callers-internal (name)
+ (let ((callers (make-array 100
+ :fill-pointer 0
+ :adjustable t)))
+ (hcl:sweep-all-objects
+ #'(lambda (object)
+ (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
+ #-Harlequin-PC-Lisp (sys::callablep object)
+ (system::find-constant$funcallable name object))
+ (vector-push-extend object callers))))
+ ;; Delay dspec:object-dspec until after sweep-all-objects
+ ;; to reduce allocation problems.
+ (loop for object across callers
+ collect (if (symbolp object)
+ (list 'function object)
+ (or (dspec:object-dspec object) object)))))
+
+;; only for lispworks 4.2 and above
+#-lispworks4.1
+(progn
+ (defxref who-references hcl:who-references)
+ (defxref who-binds hcl:who-binds)
+ (defxref who-sets hcl:who-sets))
+
+(defimplementation who-specializes (classname)
+ (let ((methods (clos:class-direct-methods (find-class classname))))
+ (xref-results (mapcar #'dspec:object-dspec methods))))
+
+(defun xref-results (dspecs)
+ (flet ((frob-locs (dspec locs)
+ (cond (locs
+ (loop for (name loc) in locs
+ collect (list name (make-dspec-location name loc))))
+ (t `((,dspec (:error "Source location not available")))))))
+ (loop for dspec in dspecs
+ append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
+
+;;; Inspector
+(defclass lispworks-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'lispworks-inspector))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (lispworks-inspect o))
+
+(defmethod inspect-for-emacs ((o function)
+ (inspector backend-inspector))
+ (declare (ignore inspector))
+ (lispworks-inspect o))
+
+;; FIXME: slot-boundp-using-class in LW works with names so we can't
+;; use our method in swank.lisp.
+(defmethod inspect-for-emacs ((o standard-object)
+ (inspector backend-inspector))
+ (declare (ignore inspector))
+ (lispworks-inspect o))
+
+(defun lispworks-inspect (o)
+ (multiple-value-bind (names values _getter _setter type)
+ (lw:get-inspector-values o nil)
+ (declare (ignore _getter _setter))
+ (values "A value."
+ (append
+ (label-value-line "Type" type)
+ (loop for name in names
+ for value in values
+ append (label-value-line name value))))))
+
+;;; Miscellaneous
+
+(defimplementation quit-lisp ()
+ (lispworks:quit))
+
+;;; Tracing
+
+(defun parse-fspec (fspec)
+ "Return a dspec for FSPEC."
+ (ecase (car fspec)
+ ((:defmethod) `(method ,(cdr fspec)))))
+
+(defun tracedp (dspec)
+ (member dspec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (dspec)
+ (cond ((tracedp dspec)
+ (eval `(untrace ,dspec))
+ (format nil "~S is now untraced." dspec))
+ (t
+ (eval `(trace (,dspec)))
+ (format nil "~S is now traced." dspec))))
+
+(defimplementation toggle-trace (fspec)
+ (toggle-trace-aux (parse-fspec fspec)))
+
+;;; Multithreading
+
+(defimplementation initialize-multiprocessing (continuation)
+ (cond ((not mp::*multiprocessing*)
+ (push (list "Initialize SLIME" '() continuation)
+ mp:*initial-processes*)
+ (mp:initialize-multiprocessing))
+ (t (funcall continuation))))
+
+(defimplementation spawn (fn &key name)
+ (let ((mp:*process-initial-bindings*
+ (remove (find-package :cl)
+ mp:*process-initial-bindings*
+ :key (lambda (x) (symbol-package (car x))))))
+ (mp:process-run-function name () fn)))
+
+(defvar *id-lock* (mp:make-lock))
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (mp:with-lock (*id-lock*)
+ (or (getf (mp:process-plist thread) 'id)
+ (setf (getf (mp:process-plist thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (find id (mp:list-all-processes)
+ :key (lambda (p) (getf (mp:process-plist p) 'id))))
+
+(defimplementation thread-name (thread)
+ (mp:process-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "~A ~D"
+ (mp:process-whostate thread)
+ (mp:process-priority thread)))
+
+(defimplementation make-lock (&key name)
+ (mp:make-lock :name name))
+
+(defimplementation call-with-lock-held (lock function)
+ (mp:with-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ mp:*current-process*)
+
+(defimplementation all-threads ()
+ (mp:list-all-processes))
+
+(defimplementation interrupt-thread (thread fn)
+ (mp:process-interrupt thread fn))
+
+(defimplementation kill-thread (thread)
+ (mp:process-kill thread))
+
+(defimplementation thread-alive-p (thread)
+ (mp:process-alive-p thread))
+
+(defvar *mailbox-lock* (mp:make-lock))
+
+(defun mailbox (thread)
+ (mp:with-lock (*mailbox-lock*)
+ (or (getf (mp:process-plist thread) 'mailbox)
+ (setf (getf (mp:process-plist thread) 'mailbox)
+ (mp:make-mailbox)))))
+
+(defimplementation receive ()
+ (mp:mailbox-read (mailbox mp:*current-process*)))
+
+(defimplementation send (thread object)
+ (mp:mailbox-send (mailbox thread) object))
+
+;;; Some intergration with the lispworks environment
+
+(defun swank-sym (name) (find-symbol (string name) :swank))
+
+(defimplementation emacs-connected ()
+ (when (eq (eval (swank-sym :*communication-style*))
+ nil)
+ (set-sigint-handler))
+ ;; pop up the slime debugger by default
+ (let ((lw:*handle-warn-on-redefinition* :warn))
+ (defmethod env-internals:environment-display-notifier
+ (env &key restarts condition)
+ (declare (ignore restarts))
+ (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*))
+ (defmethod env-internals:environment-display-debugger (env)
+ *debug-io*)))
+
+(defimplementation make-stream-interactive (stream)
+ (unless (find-method #'stream:stream-soft-force-output nil `((eql ,stream))
+ nil)
+ (let ((lw:*handle-warn-on-redefinition* :warn))
+ (defmethod stream:stream-soft-force-output ((o (eql stream)))
+ (force-output o)))))
+
+(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
+ (apply (swank-sym :y-or-n-p-in-emacs) msg args))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-kind :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :weak-kind :value args))
Added: branches/bos/thirdparty/emacs/slime/swank-loader.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-loader.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,237 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; swank-loader.lisp --- Compile and load the Slime backend.
+;;;
+;;; Created 2003, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+;; If you want customize the source- or fasl-directory you can set
+;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
+;; before loading this files. (you also need to create the
+;; swank-loader package.)
+;; E.g.:
+;;
+;; (make-package :swank-loader)
+;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
+;; (load ".../swank-loader.lisp")
+
+(cl:defpackage :swank-loader
+ (:use :cl)
+ (:export :load-swank
+ :*source-directory*
+ :*fasl-directory*))
+
+(cl:in-package :swank-loader)
+
+(defvar *source-directory*
+ (make-pathname :name nil :type nil
+ :defaults (or *load-pathname* *default-pathname-defaults*))
+ "The directory where to look for the source.")
+
+(defparameter *sysdep-files*
+ (append
+ '()
+ #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl")
+ #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl")
+ #+sbcl '("swank-source-path-parser" "swank-source-file-cache"
+ "swank-sbcl" "swank-gray")
+ #+openmcl '("metering" "swank-openmcl" "swank-gray")
+ #+lispworks '("swank-lispworks" "swank-gray")
+ #+allegro '("swank-allegro" "swank-gray")
+ #+clisp '("xref" "metering" "swank-clisp" "swank-gray")
+ #+armedbear '("swank-abcl")
+ #+cormanlisp '("swank-corman" "swank-gray")
+ #+ecl '("swank-ecl" "swank-gray")
+ ))
+
+(defparameter *implementation-features*
+ '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp
+ :armedbear :gcl :ecl :scl))
+
+(defparameter *os-features*
+ '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux
+ :unix))
+
+(defparameter *architecture-features*
+ '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
+ :sparc64 :sparc :hppa64 :hppa))
+
+(defun lisp-version-string ()
+ #+cmu (substitute-if #\_ (lambda (x) (find x " /"))
+ (lisp-implementation-version))
+ #+scl (lisp-implementation-version)
+ #+sbcl (lisp-implementation-version)
+ #+ecl (lisp-implementation-version)
+ #+openmcl (format nil "~d.~d"
+ ccl::*openmcl-major-version*
+ ccl::*openmcl-minor-version*)
+ #+lispworks (lisp-implementation-version)
+ #+allegro (format nil
+ "~A~A~A"
+ excl::*common-lisp-version-number*
+ (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn
+ (if (member :64bit *features*) "-64bit" ""))
+ #+clisp (let ((s (lisp-implementation-version)))
+ (subseq s 0 (position #\space s)))
+ #+armedbear (lisp-implementation-version)
+ #+cormanlisp (lisp-implementation-version))
+
+(defun unique-directory-name ()
+ "Return a name that can be used as a directory name that is
+unique to a Lisp implementation, Lisp implementation version,
+operating system, and hardware architecture."
+ (flet ((first-of (features)
+ (loop for f in features
+ when (find f *features*) return it))
+ (maybe-warn (value fstring &rest args)
+ (cond (value)
+ (t (apply #'warn fstring args)
+ "unknown"))))
+ (let ((lisp (maybe-warn (first-of *implementation-features*)
+ "No implementation feature found in ~a."
+ *implementation-features*))
+ (os (maybe-warn (first-of *os-features*)
+ "No os feature found in ~a." *os-features*))
+ (arch (maybe-warn (first-of *architecture-features*)
+ "No architecture feature found in ~a."
+ *architecture-features*))
+ (version (maybe-warn (lisp-version-string)
+ "Don't know how to get Lisp ~
+ implementation version.")))
+ (format nil "~(~@{~a~^-~}~)" lisp version os arch))))
+
+(defun file-newer-p (new-file old-file)
+ "Returns true if NEW-FILE is newer than OLD-FILE."
+ (> (file-write-date new-file) (file-write-date old-file)))
+
+(defun slime-version-string ()
+ "Return a string identifying the SLIME version.
+Return nil if nothing appropriate is available."
+ (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*)
+ :if-does-not-exist nil)
+ (and s (symbol-name (read s)))))
+
+(defun default-fasl-directory ()
+ (merge-pathnames
+ (make-pathname
+ :directory `(:relative ".slime" "fasl"
+ ,@(if (slime-version-string) (list (slime-version-string)))
+ ,(unique-directory-name)))
+ (user-homedir-pathname)))
+
+(defun binary-pathname (source-pathname binary-directory)
+ "Return the pathname where SOURCE-PATHNAME's binary should be compiled."
+ (let ((cfp (compile-file-pathname source-pathname)))
+ (merge-pathnames (make-pathname :name (pathname-name cfp)
+ :type (pathname-type cfp))
+ binary-directory)))
+
+(defun handle-loadtime-error (condition binary-pathname)
+ (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
+ (format *error-output*
+ "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
+ binary-pathname condition))
+ (when (equal (directory-namestring binary-pathname)
+ (directory-namestring (default-fasl-directory)))
+ (ignore-errors (delete-file binary-pathname)))
+ (abort))
+
+(defun compile-files-if-needed-serially (files fasl-directory load)
+ "Compile each file in FILES if the source is newer than
+its corresponding binary, or the file preceding it was
+recompiled."
+ (let ((needs-recompile nil))
+ (dolist (source-pathname files)
+ (let ((binary-pathname (binary-pathname source-pathname
+ fasl-directory)))
+ (handler-case
+ (progn
+ (when (or needs-recompile
+ (not (probe-file binary-pathname))
+ (file-newer-p source-pathname binary-pathname))
+ ;; need a to recompile source-pathname, so we'll
+ ;; need to recompile everything after this too.
+ (setq needs-recompile t)
+ (ensure-directories-exist binary-pathname)
+ (compile-file source-pathname :output-file binary-pathname
+ :print nil
+ :verbose t))
+ (when load
+ (load binary-pathname :verbose t)))
+ ;; Fail as early as possible
+ (serious-condition (c)
+ (handle-loadtime-error c binary-pathname)))))))
+
+#+(or cormanlisp ecl)
+(defun compile-files-if-needed-serially (files fasl-directory load)
+ "Corman Lisp and ECL have trouble with compiled files."
+ (declare (ignore fasl-directory))
+ (when load
+ (dolist (file files)
+ (load file :verbose t)
+ (force-output))))
+
+(defun load-user-init-file ()
+ "Load the user init file, return NIL if it does not exist."
+ (load (merge-pathnames (user-homedir-pathname)
+ (make-pathname :name ".swank" :type "lisp"))
+ :if-does-not-exist nil))
+
+(defun load-site-init-file (directory)
+ (load (make-pathname :name "site-init" :type "lisp"
+ :defaults directory)
+ :if-does-not-exist nil))
+
+(defun source-files (names src-dir)
+ (mapcar (lambda (name)
+ (make-pathname :name (string-downcase name) :type "lisp"
+ :defaults src-dir))
+ names))
+
+(defun swank-source-files (src-dir)
+ (source-files `("swank-backend" ,@*sysdep-files* "swank")
+ src-dir))
+
+(defvar *fasl-directory* (default-fasl-directory)
+ "The directory where fasl files should be placed.")
+
+(defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
+ swank-fancy-inspector
+ swank-presentations swank-presentation-streams
+ #+(or asdf sbcl) swank-asdf
+ )
+ "List of names for contrib modules.")
+
+(defun append-dir (absolute name)
+ (merge-pathnames
+ (make-pathname :directory `(:relative ,name) :defaults absolute)
+ absolute))
+
+(defun contrib-src-dir (src-dir)
+ (append-dir src-dir "contrib"))
+
+(defun contrib-source-files (src-dir)
+ (source-files *contribs* (contrib-src-dir src-dir)))
+
+(defun load-swank (&key
+ (source-directory *source-directory*)
+ (fasl-directory *fasl-directory*)
+ (contrib-fasl-directory
+ (append-dir fasl-directory "contrib")))
+ (compile-files-if-needed-serially (swank-source-files source-directory)
+ fasl-directory t)
+ (compile-files-if-needed-serially (contrib-source-files source-directory)
+ contrib-fasl-directory nil))
+
+(load-swank)
+
+(setq swank::*swank-wire-protocol-version* (slime-version-string))
+(setq swank::*load-path*
+ (append swank::*load-path* (list (contrib-src-dir *source-directory*))))
+(swank-backend::warn-unimplemented-interfaces)
+(load-site-init-file *source-directory*)
+(load-user-init-file)
+(swank:run-after-init-hook)
Added: branches/bos/thirdparty/emacs/slime/swank-openmcl.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-openmcl.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,985 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; openmcl-swank.lisp --- SLIME backend for OpenMCL.
+;;;
+;;; Copyright (C) 2003, James Bielman <jamesjb(a)jamesjb.com>
+;;;
+;;; This program is licensed under the terms of the Lisp Lesser GNU
+;;; Public License, known as the LLGPL, and distributed with OpenMCL
+;;; as the file "LICENSE". The LLGPL consists of a preamble and the
+;;; LGPL, which is distributed with OpenMCL as the file "LGPL". Where
+;;; these conflict, the preamble takes precedence.
+;;;
+;;; The LLGPL is also available online at
+;;; http://opensource.franz.com/preamble.html
+
+;;;
+;;; This is the beginning of a Slime backend for OpenMCL. It has been
+;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would
+;;; be interested in hearing the results with other versions.
+;;;
+;;; Additionally, reporting the positions of warnings accurately requires
+;;; a small patch to the OpenMCL file compiler, which may be found at:
+;;;
+;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff
+;;;
+;;; Things that work:
+;;;
+;;; * Evaluation of forms with C-M-x.
+;;; * Compilation of defuns with C-c C-c.
+;;; * File compilation with C-c C-k.
+;;; * Most of the debugger functionality, except EVAL-IN-FRAME,
+;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS.
+;;; * Macroexpanding with C-c RET.
+;;; * Disassembling the symbol at point with C-c M-d.
+;;; * Describing symbol at point with C-c C-d.
+;;; * Compiler warnings are trapped and sent to Emacs using the buffer
+;;; position of the offending top level form.
+;;; * Symbol completion and apropos.
+;;;
+;;; Things that sort of work:
+;;;
+;;; * WHO-CALLS is implemented but is only able to return the file a
+;;; caller is defined in---source location information is not
+;;; available.
+;;;
+;;; Things that aren't done yet:
+;;;
+;;; * Cross-referencing.
+;;; * Due to unimplementation functionality the test suite does not
+;;; run correctly (it hangs upon entering the debugger).
+;;;
+
+(in-package :swank-backend)
+
+(import-from :ccl *gray-stream-symbols* :swank-backend)
+
+(require 'xref)
+
+;;; swank-mop
+
+(import-to-swank-mop
+ '( ;; classes
+ cl:standard-generic-function
+ ccl::standard-slot-definition
+ cl:method
+ cl:standard-class
+ ccl::eql-specializer
+ openmcl-mop:finalize-inheritance
+ ;; standard-class readers
+ openmcl-mop:class-default-initargs
+ openmcl-mop:class-direct-default-initargs
+ openmcl-mop:class-direct-slots
+ openmcl-mop:class-direct-subclasses
+ openmcl-mop:class-direct-superclasses
+ openmcl-mop:class-finalized-p
+ cl:class-name
+ openmcl-mop:class-precedence-list
+ openmcl-mop:class-prototype
+ openmcl-mop:class-slots
+ openmcl-mop:specializer-direct-methods
+ ;; eql-specializer accessors
+ openmcl-mop:eql-specializer-object
+ ;; generic function readers
+ openmcl-mop:generic-function-argument-precedence-order
+ openmcl-mop:generic-function-declarations
+ openmcl-mop:generic-function-lambda-list
+ openmcl-mop:generic-function-methods
+ openmcl-mop:generic-function-method-class
+ openmcl-mop:generic-function-method-combination
+ openmcl-mop:generic-function-name
+ ;; method readers
+ openmcl-mop:method-generic-function
+ openmcl-mop:method-function
+ openmcl-mop:method-lambda-list
+ openmcl-mop:method-specializers
+ openmcl-mop:method-qualifiers
+ ;; slot readers
+ openmcl-mop:slot-definition-allocation
+ ccl::slot-definition-documentation
+ openmcl-mop:slot-value-using-class
+ openmcl-mop:slot-definition-initargs
+ openmcl-mop:slot-definition-initform
+ openmcl-mop:slot-definition-initfunction
+ openmcl-mop:slot-definition-name
+ openmcl-mop:slot-definition-type
+ openmcl-mop:slot-definition-readers
+ openmcl-mop:slot-definition-writers
+ openmcl-mop:slot-boundp-using-class
+ openmcl-mop:slot-makunbound-using-class))
+
+(defun specializer-name (spec)
+ (etypecase spec
+ (cons spec)
+ (class (class-name spec))
+ (ccl::eql-specializer `(eql ,(ccl::eql-specializer-object spec)))))
+
+(defun swank-mop:compute-applicable-methods-using-classes (gf args)
+ (let* ((methods (ccl::%gf-methods gf))
+ (args-length (length args))
+ (bits (ccl::inner-lfun-bits gf))
+ arg-count res)
+ (when methods
+ (setq arg-count (length (ccl::%method-specializers (car methods))))
+ (unless (<= arg-count args-length)
+ (error "Too few args to ~s" gf))
+ (unless (or (logbitp ccl::$lfbits-rest-bit bits)
+ (logbitp ccl::$lfbits-restv-bit bits)
+ (logbitp ccl::$lfbits-keys-bit bits)
+ (<= args-length
+ (+ (ldb ccl::$lfbits-numreq bits) (ldb ccl::$lfbits-numopt bits))))
+ (error "Too many args to ~s" gf))
+ (let ((cpls (make-list arg-count)))
+ (declare (dynamic-extent cpls))
+ (do* ((args-tail args (cdr args-tail))
+ (cpls-tail cpls (cdr cpls-tail)))
+ ((null cpls-tail))
+ (setf (car cpls-tail)
+ (ccl::%class-precedence-list (car args-tail))))
+ (flet ((%method-applicable-p (method args cpls)
+ (do* ((specs (ccl::%method-specializers method) (ccl::%cdr specs))
+ (args args (ccl::%cdr args))
+ (cpls cpls (ccl::%cdr cpls)))
+ ((null specs) t)
+ (let ((spec (ccl::%car specs)))
+ (if (typep spec 'ccl::eql-specializer)
+ (unless (subtypep (ccl::%car args) (class-of (ccl::eql-specializer-object spec)))
+ (return nil))
+ (unless (ccl:memq spec (ccl::%car cpls))
+ (return nil)))))))
+ (dolist (m methods)
+ (if (%method-applicable-p m args cpls)
+ (push m res))))
+ (ccl::sort-methods res cpls (ccl::%gf-precedence-list gf))))))
+
+;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port)
+ (ccl:make-socket :connect :passive :local-port port
+ :local-host host :reuse-address t))
+
+(defimplementation local-port (socket)
+ (ccl:local-port socket))
+
+(defimplementation close-socket (socket)
+ (close socket))
+
+(defimplementation accept-connection (socket &key external-format
+ buffering timeout)
+ (declare (ignore buffering timeout
+ #-openmcl-unicode-strings external-format))
+ #+openmcl-unicode-strings
+ (when external-format
+ (let ((keys (ccl::socket-keys socket)))
+ (setf (getf keys :external-format) external-format
+ (slot-value socket 'ccl::keys) keys)))
+ (ccl:accept-connection socket :wait t))
+
+#+openmcl-unicode-strings
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")))
+
+#+openmcl-unicode-strings
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defimplementation emacs-connected ()
+ (setq ccl::*interactive-abort-process* ccl::*current-process*))
+
+(defimplementation make-stream-interactive (stream)
+ (typecase stream
+ (ccl:fundamental-output-stream
+ (push stream ccl::*auto-flush-streams*))))
+
+;;; Unix signals
+
+(defimplementation call-without-interrupts (fn)
+ (ccl:without-interrupts (funcall fn)))
+
+(defimplementation getpid ()
+ (ccl::getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "openmcl")
+
+(defvar *break-in-sldb* t)
+
+(let ((ccl::*warn-if-redefine-kernel* nil))
+ (ccl::advise
+ cl::break
+ (if (and *break-in-sldb*
+ (find ccl::*current-process* (symbol-value (intern "*CONNECTIONS*" 'swank))
+ :key (intern "CONNECTION.REPL-THREAD" 'swank)))
+ (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
+ :format-control (or string "Break")
+ :format-arguments args)))
+ (let ((previous-f nil)
+ (previous-f2 nil))
+ (block find-frame
+ (map-backtrace
+ #'(lambda(frame-number p context lfun pc)
+ (declare (ignore frame-number context pc))
+ (when (eq previous-f2 'break-in-sldb)
+ (record-stack-top p)
+ (return-from find-frame))
+ (setq previous-f2 previous-f)
+ (setq previous-f (ccl::lfun-name lfun)))))
+ (restart-case (invoke-debugger c)
+ (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t))
+ )))
+
+; In previous version the code that recorded the function that had an
+; error or which was interrupted was not thread safe. This code repairs that by
+; associating the frame pointer with a process via the *process-to-stack-top* hash.
+
+(defvar *process-to-stack-top* (make-hash-table :test 'eql))
+
+(defun record-stack-top (frame)
+ (setf (gethash (ccl::process-serial-number ccl::*current-process*) *process-to-stack-top* )
+ frame))
+
+(defun grab-stack-top ()
+ (let ((psn (ccl::process-serial-number ccl::*current-process*)))
+ (ccl::without-interrupts
+ (prog1
+ (gethash psn *process-to-stack-top*)
+ (setf (gethash psn *process-to-stack-top*) nil)))))
+
+(defmethod ccl::application-error :before (application condition error-pointer)
+ (declare (ignore application condition))
+ (record-stack-top error-pointer)
+ nil)
+
+;;; Evaluation
+
+(defimplementation arglist (fname)
+ (arglist% fname))
+
+(defmethod arglist% ((f symbol))
+ (ccl:arglist f))
+
+(defmethod arglist% ((f function))
+ (ccl:arglist (ccl:function-name f)))
+
+(defimplementation function-name (function)
+ (ccl:function-name function))
+
+;;; Compilation
+
+(defvar *buffer-offset* nil)
+(defvar *buffer-name* nil)
+
+(defun condition-source-position (condition)
+ "Return the position in the source file of a compiler condition."
+ (+ 1
+ (or *buffer-offset* 0)
+ ;; alanr sometimes returned stream position nil.
+ (or (ccl::compiler-warning-stream-position condition) 0)))
+
+
+(defun handle-compiler-warning (condition)
+ "Construct a compiler note for Emacs from a compiler warning
+condition."
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :message (format nil "~A" condition)
+ :severity :warning
+ :location
+ (let ((position (condition-source-position condition)))
+ (if *buffer-name*
+ (make-location
+ (list :buffer *buffer-name*)
+ (list :position position t))
+ (if (ccl::compiler-warning-file-name condition)
+ (make-location
+ (list :file (namestring (truename (ccl::compiler-warning-file-name condition))))
+ (list :position position t))))))))
+
+(defun temp-file-name ()
+ "Return a temporary file name to compile strings into."
+ (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (handler-bind ((ccl::compiler-warning 'handle-compiler-warning))
+ (funcall function)))
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (declare (ignore external-format))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (*buffer-offset* nil))
+ (compile-file filename :load load-p))))
+
+(defimplementation frame-var-value (frame var)
+ (block frame-var-value
+ (map-backtrace
+ #'(lambda(frame-number p context lfun pc)
+ (when (= frame frame-number)
+ (return-from frame-var-value
+ (multiple-value-bind (total vsp parent-vsp)
+ (ccl::count-values-in-frame p context)
+ (loop for count below total
+ with varcount = -1
+ for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp))
+ when name do (incf varcount)
+ until (= varcount var)
+ finally (return value))
+ )))))))
+
+(defun xref-locations (relation name &optional (inverse nil))
+ (flet ((function-source-location (entry)
+ (multiple-value-bind (info name)
+ (ccl::edit-definition-p
+ (ccl::%db-key-from-xref-entry entry)
+ (if (eql (ccl::xref-entry-type entry)
+ 'macro)
+ 'function
+ (ccl::xref-entry-type entry)))
+ (cond ((not info)
+ (list :error
+ (format nil "No source info available for ~A"
+ (ccl::xref-entry-name entry))))
+ ((typep (caar info) 'ccl::method)
+ `(:location
+ (:file ,(remove-filename-quoting
+ (namestring (translate-logical-pathname
+ (cdr (car info))))))
+ (:method
+ ,(princ-to-string (ccl::method-name (caar info)))
+ ,(mapcar 'princ-to-string
+ (mapcar #'specializer-name
+ (ccl::method-specializers
+ (caar info))))
+ ,@(mapcar 'princ-to-string
+ (ccl::method-qualifiers (caar info))))
+ nil))
+ (t
+ (canonicalize-location (cdr (first info)) name))))))
+ (declare (dynamic-extent #'function-source-location))
+ (loop for xref in (if inverse
+ (ccl::get-relation relation name
+ :wild :exhaustive t)
+ (ccl::get-relation relation
+ :wild name :exhaustive t))
+ for function = (ccl::xref-entry-name xref)
+ collect `((function ,function)
+ ,(function-source-location xref)))))
+
+(defimplementation who-binds (name)
+ (xref-locations :binds name))
+
+(defimplementation who-macroexpands (name)
+ (xref-locations :macro-calls name t))
+
+(defimplementation who-references (name)
+ (remove-duplicates
+ (append (xref-locations :references name)
+ (xref-locations :sets name)
+ (xref-locations :binds name))
+ :test 'equal))
+
+(defimplementation who-sets (name)
+ (xref-locations :sets name))
+
+(defimplementation who-calls (name)
+ (remove-duplicates
+ (append
+ (xref-locations :direct-calls name)
+ (xref-locations :indirect-calls name)
+ (xref-locations :macro-calls name t))
+ :test 'equal))
+
+(defimplementation list-callees (name)
+ (remove-duplicates
+ (append
+ (xref-locations :direct-calls name t)
+ (xref-locations :macro-calls name nil))
+ :test 'equal))
+
+(defimplementation who-specializes (class)
+ (if (symbolp class) (setq class (find-class class)))
+ (remove-duplicates
+ (append (mapcar (lambda(m)
+ (let ((location (function-source-location (ccl::method-function m))))
+ (if (eq (car location) :error)
+ (setq location nil ))
+ `((method ,(ccl::method-name m)
+ ,(mapcar #'specializer-name (ccl::method-specializers m))
+ ,@(ccl::method-qualifiers m))
+ ,location)))
+ (ccl::%class.direct-methods class))
+ (mapcan 'who-specializes (ccl::%class-direct-subclasses class)))
+ :test 'equal))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-offset* position)
+ (filename (temp-file-name)))
+ (unwind-protect
+ (with-open-file (s filename :direction :output :if-exists :error)
+ (write-string string s))
+ (let ((binary-filename (compile-file filename :load t)))
+ (delete-file binary-filename)))
+ (delete-file filename))))
+
+;;; Profiling (alanr: lifted from swank-clisp)
+
+(defimplementation profile (fname)
+ (eval `(mon:monitor ,fname))) ;monitor is a macro
+
+(defimplementation profiled-functions ()
+ mon:*monitored-functions*)
+
+(defimplementation unprofile (fname)
+ (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
+
+(defimplementation unprofile-all ()
+ (mon:unmonitor))
+
+(defimplementation profile-report ()
+ (mon:report-monitoring))
+
+(defimplementation profile-reset ()
+ (mon:reset-all-monitoring))
+
+(defimplementation profile-package (package callers-p methods)
+ (declare (ignore callers-p methods))
+ (mon:monitor-all package))
+
+;;; Debugging
+
+(defun openmcl-set-debug-switches ()
+ (setq ccl::*fasl-save-definitions* nil)
+ (setq ccl::*fasl-save-doc-strings* t)
+ (setq ccl::*fasl-save-local-symbols* t)
+ (setq ccl::*ppc2-compiler-register-save-label* t)
+ (setq ccl::*save-arglist-info* t)
+ (setq ccl::*save-definitions* nil)
+ (setq ccl::*save-doc-strings* t)
+ (setq ccl::*save-local-symbols* t)
+ (ccl::start-xref))
+
+(defvar *sldb-stack-top* nil)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* ((*debugger-hook* nil)
+ (*sldb-stack-top* (grab-stack-top))
+ (ccl::*signal-printing-errors* nil)) ; don't let error while printing error take us down
+ (funcall debugger-loop-fn)))
+
+(defun backtrace-context ()
+ (if (and (= ccl::*openmcl-major-version* 0)
+ (<= ccl::*openmcl-minor-version* 14)
+ (< ccl::*openmcl-revision* 2))
+ (ccl::%current-tcr)
+ nil))
+
+(defun map-backtrace (function &optional
+ (start-frame-number 0)
+ (end-frame-number most-positive-fixnum))
+ "Call FUNCTION passing information about each stack frame
+ from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
+ (let ((context (backtrace-context))
+ (frame-number 0)
+ (top-stack-frame (or *sldb-stack-top*
+ (ccl::%get-frame-ptr))))
+ (do* ((p top-stack-frame (ccl::parent-frame p context))
+ (q (ccl::last-frame-ptr context)))
+ ((or (null p) (eq p q) (ccl::%stack< q p context))
+ (values))
+ (multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
+ (when lfun
+ (if (and (>= frame-number start-frame-number)
+ (< frame-number end-frame-number))
+ (funcall function frame-number p context lfun pc))
+ (incf frame-number))))))
+
+;; May 13, 2004 alanr: use prin1 instead of princ so I see " around strings. Write ' in front of symbol names and lists.
+;; Sept 6, 2004 alanr: use builtin ccl::frame-supplied-args
+
+(defun frame-arguments (p context lfun pc)
+ "Returns a string representing the arguments of a frame."
+ (multiple-value-bind (args types names count nclosed)
+ (ccl::frame-supplied-args p lfun pc nil context)
+ (declare (ignore count nclosed))
+ (let ((result nil))
+ (loop named loop
+ for var = (cond
+ ((null args)
+ (return-from loop))
+ ((atom args)
+ (prog1
+ args
+ (setf args nil)))
+ (t (pop args)))
+ for type in types
+ for name in names
+ do
+ (when (or (symbolp var) (listp var)) (setq var (list 'quote var)))
+ (cond ((equal type "keyword")
+ (push (format nil "~S ~A"
+ (intern (symbol-name name) "KEYWORD")
+ (prin1-to-string var))
+ result))
+ (t (push (prin1-to-string var) result))))
+ (format nil "~{ ~A~}" (nreverse result)))))
+
+
+;; XXX should return something less stringy
+;; alanr May 13, 2004: put #<> around anonymous functions in the backtrace.
+
+(defimplementation compute-backtrace (start-frame-number end-frame-number)
+ (let (result)
+ (map-backtrace (lambda (frame-number p context lfun pc)
+ (declare (ignore frame-number))
+ (push (with-output-to-string (s)
+ (format s "(~A~A)"
+ (if (ccl::function-name lfun)
+ (ccl::%lfun-name-string lfun)
+ lfun)
+ (frame-arguments p context lfun pc)))
+ result))
+ start-frame-number end-frame-number)
+ (nreverse result)))
+
+(defimplementation print-frame (frame stream)
+ (princ frame stream))
+
+(defimplementation frame-locals (index)
+ (block frame-locals
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (when (= frame-number index)
+ (multiple-value-bind (count vsp parent-vsp)
+ (ccl::count-values-in-frame p context)
+ (let (result)
+ (dotimes (i count)
+ (multiple-value-bind (var type name)
+ (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
+ (declare (ignore type))
+ (when name
+ (push (list
+ :name name
+ :id 0
+ :value var)
+ result))))
+ (return-from frame-locals (nreverse result)))))))))
+
+(defimplementation frame-catch-tags (index &aux my-frame)
+ (block frame-catch-tags
+ (map-backtrace
+ (lambda (frame-number p context 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 (ccl::%current-tcr)) then (ccl::next-catch catch)
+ while catch
+ for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp
+ for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell)
+ until (ccl::%stack< p csp context)
+ when (ccl::%stack< my-frame csp context)
+ collect (cond
+ ((symbolp tag)
+ tag)
+ ((and (listp tag)
+ (typep (car tag) 'restart))
+ `(:restart ,(restart-name (car tag)))))))))))))
+
+(defimplementation disassemble-frame (the-frame-number)
+ (let ((function-to-disassemble nil))
+ (block find-frame
+ (map-backtrace
+ (lambda(frame-number p context lfun pc)
+ (declare (ignore p context pc))
+ (when (= frame-number the-frame-number)
+ (setq function-to-disassemble lfun)
+ (return-from find-frame)))))
+ (ccl::print-ppc-instructions
+ *standard-output*
+ (ccl::function-to-dll-header function-to-disassemble) nil)))
+
+;;;
+
+(defun canonicalize-location (file symbol)
+ (etypecase file
+ ((or string pathname)
+ (multiple-value-bind (truename c) (ignore-errors (namestring (truename file)))
+ (cond (c (list :error (princ-to-string c)))
+ (t (make-location (list :file (remove-filename-quoting truename))
+ (list :function-name (princ-to-string symbol)))))))))
+
+(defun remove-filename-quoting (string)
+ (if (search "\\" string)
+ (read-from-string (format nil "\"~a\"" string))
+ string))
+
+(defun maybe-method-location (type)
+ (when (typep type 'ccl::method)
+ `((method ,(ccl::method-name type)
+ ,(mapcar #'specializer-name (ccl::method-specializers type))
+ ,@(ccl::method-qualifiers type))
+ ,(function-source-location (ccl::method-function type)))))
+
+(defimplementation find-definitions (symbol)
+ (let* ((info (ccl::get-source-files-with-types&classes symbol)))
+ (loop for (type . file) in info
+ when (not (equal "l1-boot-3" (pathname-name file))) ; alanr: This is a bug - there's nothing in there
+ collect (or (maybe-method-location type)
+ (list (list type symbol)
+ (canonicalize-location file symbol))))))
+
+
+(defun function-source-location (function)
+ (multiple-value-bind (info name) (ccl::edit-definition-p function)
+ (cond ((not info) (list :error (format nil "No source info available for ~A" function)))
+ ((typep (caar info) 'ccl::method)
+ `(:location
+ (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) )))
+ (:method ,(princ-to-string (ccl::method-name (caar info)))
+ ,(mapcar 'princ-to-string
+ (mapcar #'specializer-name
+ (ccl::method-specializers (caar info))))
+ ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info))))
+ nil))
+ (t (canonicalize-location (cdr (first info)) name)))))
+
+(defimplementation frame-source-location-for-emacs (index)
+ "Return to Emacs the location of the source code for the
+function in a debugger frame. In OpenMCL, we are not able to
+find the precise position of the frame, but we do attempt to give
+at least the filename containing it."
+ (block frame-source-location-for-emacs
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (declare (ignore p context pc))
+ (when (and (= frame-number index) lfun)
+ (return-from frame-source-location-for-emacs
+ (function-source-location lfun)))))))
+
+(defimplementation eval-in-frame (form index)
+ (block eval-in-frame
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (when (= frame-number index)
+ (multiple-value-bind (count vsp parent-vsp)
+ (ccl::count-values-in-frame p context)
+ (let ((bindings nil))
+ (dotimes (i count)
+ (multiple-value-bind (var type name)
+ (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
+ (declare (ignore type))
+ (when name
+ (push (list name `',var) bindings))
+ ))
+ (return-from eval-in-frame
+ (eval `(let ,bindings
+ (declare (ignorable ,@(mapcar 'car bindings)))
+ ,form)))
+ )))))))
+
+(defimplementation return-from-frame (index form)
+ (let ((values (multiple-value-list (eval-in-frame form index))))
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (declare (ignore context lfun pc))
+ (when (= frame-number index)
+ (ccl::apply-in-frame p #'values values))))))
+
+(defimplementation restart-frame (index)
+ (map-backtrace
+ (lambda (frame-number p context lfun pc)
+ (when (= frame-number index)
+ (ccl::apply-in-frame p lfun
+ (ccl::frame-supplied-args p lfun pc nil context))))))
+
+;;; Utilities
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind &optional (sym symbol))
+ (or (documentation sym kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (when (boundp symbol)
+ (doc 'variable)))
+ (maybe-push
+ :function (if (fboundp symbol)
+ (doc 'function)))
+ (maybe-push
+ :setf (let ((setf-function-name (ccl::setf-function-spec-name
+ `(setf ,symbol))))
+ (when (fboundp setf-function-name)
+ (doc 'function setf-function-name))))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (ecase namespace
+ (:variable
+ (describe symbol))
+ ((:function :generic-function)
+ (describe (symbol-function symbol)))
+ (:setf
+ (describe (ccl::setf-function-spec-name `(setf ,symbol))))
+ (:class
+ (describe (find-class symbol)))))
+
+(defimplementation toggle-trace (spec)
+ "We currently ignore just about everything."
+ (ecase (car spec)
+ (setf
+ (ccl::%trace spec))
+ (:defmethod
+ (ccl::%trace (second spec)))
+ (:defgeneric
+ (ccl::%trace (second spec)))
+ (:call
+ (toggle-trace (third spec)))
+ ;; mb: FIXME: shouldn't we warn that we're not doing anything for
+ ;; these two?
+ (:labels nil)
+ (:flet nil))
+ t)
+
+;;; XREF
+
+(defimplementation list-callers (symbol)
+ (loop for caller in (ccl::callers symbol)
+ append (multiple-value-bind (info name type specializers modifiers)
+ (ccl::edit-definition-p caller)
+ (loop for (nil . file) in info
+ collect (list (if (eq t type)
+ name
+ `(,type ,name ,specializers
+ ,@modifiers))
+ (canonicalize-location file name))))))
+;;; Macroexpansion
+
+(defvar *value2tag* (make-hash-table))
+
+(do-symbols (s (find-package 'arch))
+ (if (and (> (length (symbol-name s)) 7)
+ (string= (symbol-name s) "SUBTAG-" :end1 7)
+ (boundp s)
+ (numberp (symbol-value s))
+ (< (symbol-value s) 255))
+ (setf (gethash (symbol-value s) *value2tag*) s)))
+
+;;;; Inspection
+
+(defclass openmcl-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'openmcl-inspector))
+
+(defimplementation describe-primitive-type (thing)
+ (let ((typecode (ccl::typecode thing)))
+ (if (gethash typecode *value2tag*)
+ (string (gethash typecode *value2tag*))
+ (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (let* ((i (inspector::make-inspector o))
+ (count (inspector::compute-line-count i))
+ (lines
+ (loop
+ for l below count
+ for (value label) = (multiple-value-list
+ (inspector::line-n i l))
+ collect `(:value ,label ,(string-capitalize (format nil "~a" label)))
+ collect " = "
+ collect `(:value ,value)
+ collect '(:newline))))
+ (values (with-output-to-string (s)
+ (let ((*print-lines* 1)
+ (*print-right-margin* 80))
+ (pprint o s)))
+ lines)))
+
+(defmethod inspect-for-emacs :around ((o t) (inspector backend-inspector))
+ (if (or (uvector-inspector-p o)
+ (not (ccl:uvectorp o)))
+ (call-next-method)
+ (multiple-value-bind (title content)
+ (call-next-method)
+ (values
+ title
+ (append content
+ `((:newline)
+ (:value ,(make-instance 'uvector-inspector :object o)
+ "Underlying UVECTOR")))))))
+
+(defclass uvector-inspector ()
+ ((object :initarg :object)))
+
+(defgeneric uvector-inspector-p (object)
+ (:method ((object t)) nil)
+ (:method ((object uvector-inspector)) t))
+
+(defmethod inspect-for-emacs ((uv uvector-inspector)
+ (inspector backend-inspector))
+ (with-slots (object)
+ uv
+ (values (format nil "The UVECTOR for ~S." object)
+ (loop
+ for index below (ccl::uvsize object)
+ collect (format nil "~D: " index)
+ collect `(:value ,(ccl::uvref object index))
+ collect `(:newline)))))
+
+(defun closure-closed-over-values (closure)
+ (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure)))))
+ (loop for n below howmany
+ collect
+ (let* ((value (ccl::nth-immediate closure (+ 1 (- howmany n))))
+ (map (car (ccl::function-symbol-map (ccl::closure-function closure))))
+ (label (or (and map (svref map n)) n))
+ (cellp (ccl::closed-over-value-p value)))
+ (list label (if cellp (ccl::closed-over-value value) value))))))
+
+(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure) (inspector t))
+ (declare (ignore inspector))
+ (values
+ (format nil "A closure: ~a" c)
+ `(,@(if (arglist c)
+ (list "Its argument list is: "
+ (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c)))
+ ;; FIXME inspector-princ should load earlier
+ (list "A function of no arguments"))
+ (:newline)
+ ,@(when (documentation c t)
+ `("Documentation:" (:newline) ,(documentation c t) (:newline)))
+ ,(format nil "Closed over ~a values" (length (closure-closed-over-values c)))
+ (:newline)
+ ,@(loop for (name value) in (closure-closed-over-values c)
+ for count from 1
+ append
+ (label-value-line* ((format nil "~2,' d) ~a" count (string name)) value))))))
+
+
+
+
+;;; Multiprocessing
+
+(defvar *known-processes* '() ; FIXME: leakage. -luke
+ "Alist (ID . PROCESS MAILBOX) list of processes that we have handed
+out IDs for.")
+
+(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
+
+(defstruct (mailbox (:conc-name mailbox.))
+ (mutex (ccl:make-lock "thread mailbox"))
+ (semaphore (ccl:make-semaphore))
+ (queue '() :type list))
+
+(defimplementation spawn (fn &key name)
+ (ccl:process-run-function (or name "Anonymous (Swank)") fn))
+
+(defimplementation thread-id (thread)
+ (ccl::process-serial-number thread))
+
+(defimplementation find-thread (id)
+ (find id (ccl:all-processes) :key #'ccl::process-serial-number))
+
+(defimplementation thread-name (thread)
+ (ccl::process-name thread))
+
+(defimplementation thread-status (thread)
+ (format nil "~A" (ccl:process-whostate thread)))
+
+(defimplementation make-lock (&key name)
+ (ccl:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+ (ccl:with-lock-grabbed (lock)
+ (funcall function)))
+
+(defimplementation current-thread ()
+ ccl:*current-process*)
+
+(defimplementation all-threads ()
+ (ccl:all-processes))
+
+(defimplementation kill-thread (thread)
+ (ccl:process-kill thread))
+
+;; September 5, 2004 alanr. record the frame interrupted
+(defimplementation interrupt-thread (thread fn)
+ (ccl:process-interrupt
+ thread
+ (lambda(&rest args)
+ (let ((previous-f nil))
+ (block find-frame
+ (map-backtrace
+ #'(lambda(frame-number p context lfun pc)
+ (declare (ignore frame-number context pc))
+ (when (eq previous-f 'ccl::%pascal-functions%)
+ (record-stack-top p)
+ (return-from find-frame))
+ (setq previous-f (ccl::lfun-name lfun)))))
+ (apply fn args)))))
+
+
+(defun mailbox (thread)
+ (ccl:with-lock-grabbed (*known-processes-lock*)
+ (let ((probe (rassoc thread *known-processes* :key #'car)))
+ (cond (probe (second (cdr probe)))
+ (t (let ((mailbox (make-mailbox)))
+ (setq *known-processes*
+ (acons (ccl::process-serial-number thread)
+ (list thread mailbox)
+ (remove-if
+ (lambda(entry)
+ (string= (ccl::process-whostate (second entry)) "Exhausted"))
+ *known-processes*)
+ ))
+ mailbox))))))
+
+(defimplementation send (thread message)
+ (assert message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (ccl:with-lock-grabbed (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (ccl:signal-semaphore (mailbox.semaphore mbox)))))
+
+(defimplementation receive ()
+ (let* ((mbox (mailbox ccl:*current-process*))
+ (mutex (mailbox.mutex mbox)))
+ (ccl:wait-on-semaphore (mailbox.semaphore mbox))
+ (ccl:with-lock-grabbed (mutex)
+ (assert (mailbox.queue mbox))
+ (pop (mailbox.queue mbox)))))
+
+(defimplementation quit-lisp ()
+ (ccl::quit))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak :key args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ (apply #'make-hash-table :weak :value args))
+
+(defimplementation hash-table-weakness (hashtable)
+ (ccl::hash-table-weak-p hashtable))
Added: branches/bos/thirdparty/emacs/slime/swank-sbcl.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-sbcl.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,1327 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; swank-sbcl.lisp --- SLIME backend for SBCL.
+;;;
+;;; Created 2003, Daniel Barlow <dan(a)metacircles.com>
+;;;
+;;; This code has been placed in the Public Domain. All warranties are
+;;; disclaimed.
+
+;;; Requires the SB-INTROSPECT contrib.
+
+;;; Administrivia
+
+(in-package :swank-backend)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require 'asdf)
+ (require 'sb-bsd-sockets)
+ (require 'sb-introspect)
+ (require 'sb-posix)
+ (require 'sb-cltl2))
+
+(declaim (optimize (debug 2) (sb-c:insert-step-conditions 0)))
+
+(import-from :sb-gray *gray-stream-symbols* :swank-backend)
+
+;;; backwards compability tests
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Generate a form suitable for testing for stepper support (0.9.17)
+ ;; with #+.
+ (defun sbcl-with-new-stepper-p ()
+ (if (find-symbol "ENABLE-STEPPING" "SB-IMPL")
+ '(:and)
+ '(:or)))
+ ;; Ditto for weak hash-tables
+ (defun sbcl-with-weak-hash-tables ()
+ (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")
+ '(:and)
+ '(:or)))
+ ;; And for xref support (1.0.1)
+ (defun sbcl-with-xref-p ()
+ (if (find-symbol "WHO-CALLS" "SB-INTROSPECT")
+ '(:and)
+ '(:or)))
+ ;; ... for restart-frame support (1.0.2)
+ (defun sbcl-with-restart-frame ()
+ (if (find-symbol "FRAME-HAS-DEBUG-TAG-P" "SB-DEBUG")
+ '(:and)
+ '(:or))))
+
+;;; swank-mop
+
+(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (sb-pcl::documentation slot t))
+
+;;; TCP Server
+
+(defimplementation preferred-communication-style ()
+ (cond
+ ;; fixme: when SBCL/win32 gains better select() support, remove
+ ;; this.
+ ((member :win32 *features*) nil)
+ ((member :sb-thread *features*) :spawn)
+ (t :fd-handler)))
+
+(defun resolve-hostname (name)
+ (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name name))))
+
+(defimplementation create-socket (host port)
+ (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+ (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+ (sb-bsd-sockets:socket-listen socket 5)
+ socket))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defimplementation close-socket (socket)
+ (sb-sys:invalidate-descriptor (socket-fd socket))
+ (sb-bsd-sockets:socket-close socket))
+
+(defimplementation accept-connection (socket &key
+ external-format
+ buffering timeout)
+ (declare (ignore timeout))
+ (make-socket-io-stream (accept socket)
+ (or external-format :iso-latin-1-unix)
+ (or buffering :full)))
+
+(defvar *sigio-handlers* '()
+ "List of (key . fn) pairs to be called on SIGIO.")
+
+(defun sigio-handler (signal code scp)
+ (declare (ignore signal code scp))
+ (mapc (lambda (handler)
+ (funcall (the function (cdr handler))))
+ *sigio-handlers*))
+
+(defun set-sigio-handler ()
+ (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
+ (sigio-handler signal code scp))))
+
+(defun enable-sigio-on-fd (fd)
+ (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
+ (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
+
+(defimplementation add-sigio-handler (socket fn)
+ (set-sigio-handler)
+ (let ((fd (socket-fd socket)))
+ (format *debug-io* "Adding sigio handler: ~S ~%" fd)
+ (enable-sigio-on-fd fd)
+ (push (cons fd fn) *sigio-handlers*)))
+
+(defimplementation remove-sigio-handlers (socket)
+ (let ((fd (socket-fd socket)))
+ (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
+ (sb-sys:invalidate-descriptor fd))
+ (close socket))
+
+(defimplementation add-fd-handler (socket fn)
+ (declare (type function fn))
+ (let ((fd (socket-fd socket)))
+ (format *debug-io* "; Adding fd handler: ~S ~%" fd)
+ (sb-sys:add-fd-handler fd :input (lambda (_)
+ _
+ (funcall fn)))))
+
+(defimplementation remove-fd-handlers (socket)
+ (sb-sys:invalidate-descriptor (socket-fd socket)))
+
+(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))))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")
+ (:us-ascii "us-ascii" "us-ascii-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (socket external-format buffering)
+ (sb-bsd-sockets:socket-make-stream socket
+ :output t
+ :input t
+ :element-type 'character
+ :buffering buffering
+ #+sb-unicode :external-format
+ #+sb-unicode external-format
+ ))
+
+(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 ()))))
+
+(defimplementation call-without-interrupts (fn)
+ (declare (type function fn))
+ (sb-sys:without-interrupts (funcall fn)))
+
+(defimplementation getpid ()
+ (sb-posix:getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ "sbcl")
+
+
+;;;; Support for SBCL syntax
+
+;;; SBCL's source code is riddled with #! reader macros. Also symbols
+;;; containing `!' have special meaning. We have to work long and
+;;; hard to be able to read the source. To deal with #! reader
+;;; macros, we use a special readtable. The special symbols are
+;;; converted by a condition handler.
+
+(defun feature-in-list-p (feature list)
+ (etypecase feature
+ (symbol (member feature list :test #'eq))
+ (cons (flet ((subfeature-in-list-p (subfeature)
+ (feature-in-list-p subfeature list)))
+ (ecase (first feature)
+ (:or (some #'subfeature-in-list-p (rest feature)))
+ (:and (every #'subfeature-in-list-p (rest feature)))
+ (:not (destructuring-bind (e) (cdr feature)
+ (not (subfeature-in-list-p e)))))))))
+
+(defun shebang-reader (stream sub-character infix-parameter)
+ (declare (ignore sub-character))
+ (when infix-parameter
+ (error "illegal read syntax: #~D!" infix-parameter))
+ (let ((next-char (read-char stream)))
+ (unless (find next-char "+-")
+ (error "illegal read syntax: #!~C" next-char))
+ ;; When test is not satisfied
+ ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
+ ;; would become "unless test is satisfied"..
+ (when (let* ((*package* (find-package "KEYWORD"))
+ (*read-suppress* nil)
+ (not-p (char= next-char #\-))
+ (feature (read stream)))
+ (if (feature-in-list-p feature *features*)
+ not-p
+ (not not-p)))
+ ;; Read (and discard) a form from input.
+ (let ((*read-suppress* t))
+ (read stream t nil t))))
+ (values))
+
+(defvar *shebang-readtable*
+ (let ((*readtable* (copy-readtable nil)))
+ (set-dispatch-macro-character #\# #\!
+ (lambda (s c n) (shebang-reader s c n))
+ *readtable*)
+ *readtable*))
+
+(defun shebang-readtable ()
+ *shebang-readtable*)
+
+(defun sbcl-package-p (package)
+ (let ((name (package-name package)))
+ (eql (mismatch "SB-" name) 3)))
+
+(defun sbcl-source-file-p (filename)
+ (when filename
+ (loop for (_ pattern) in (logical-pathname-translations "SYS")
+ thereis (pathname-match-p filename pattern))))
+
+(defun guess-readtable-for-filename (filename)
+ (if (sbcl-source-file-p filename)
+ (shebang-readtable)
+ *readtable*))
+
+(defvar *debootstrap-packages* t)
+
+(defun call-with-debootstrapping (fun)
+ (handler-bind ((sb-int:bootstrap-package-not-found
+ #'sb-int:debootstrap-package))
+ (funcall fun)))
+
+(defmacro with-debootstrapping (&body body)
+ `(call-with-debootstrapping (lambda () ,@body)))
+
+(defimplementation call-with-syntax-hooks (fn)
+ (cond ((and *debootstrap-packages*
+ (sbcl-package-p *package*))
+ (with-debootstrapping (funcall fn)))
+ (t
+ (funcall fn))))
+
+(defimplementation default-readtable-alist ()
+ (let ((readtable (shebang-readtable)))
+ (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
+ collect (cons (package-name p) readtable))))
+
+;;; Utilities
+
+(defimplementation arglist (fname)
+ (sb-introspect:function-arglist fname))
+
+(defimplementation function-name (f)
+ (check-type f function)
+ (sb-impl::%fun-name f))
+
+(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
+ (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
+ (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
+ (if flags
+ ;; Symbols aren't printed with package qualifiers, but the FLAGS would
+ ;; have to be fully qualified when used inside a declaration. So we
+ ;; strip those as long as there's no better way. (FIXME)
+ `(&any ,@(remove-if-not #'(lambda (qualifier)
+ (find-symbol (symbol-name (first qualifier)) :cl))
+ flags :key #'ensure-list))
+ (call-next-method)))))
+
+(defvar *buffer-name* nil)
+(defvar *buffer-offset*)
+(defvar *buffer-substring* nil)
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning.
+This traps all compiler conditions at a lower-level than using
+C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
+craft our own error messages, which can omit a lot of redundant
+information."
+ (let ((context (sb-c::find-error-context nil)))
+ (unless (eq condition *previous-compiler-condition*)
+ (setq *previous-compiler-condition* condition)
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :severity (etypecase condition
+ (sb-c:compiler-error :error)
+ (sb-ext:compiler-note :note)
+ (style-warning :style-warning)
+ (warning :warning)
+ (error :error))
+ :short-message (brief-compiler-message-for-emacs condition)
+ :references (condition-references (real-condition condition))
+ :message (long-compiler-message-for-emacs condition context)
+ :location (compiler-note-location context))))
+
+(defun real-condition (condition)
+ "Return the encapsulated condition or CONDITION itself."
+ (typecase condition
+ (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
+ (t condition)))
+
+(defun condition-references (condition)
+ (if (typep condition 'sb-int:reference-condition)
+ (externalize-reference
+ (sb-int:reference-condition-references condition))))
+
+(defun compiler-note-location (context)
+ (if context
+ (locate-compiler-note
+ (sb-c::compiler-error-context-file-name context)
+ (compiler-source-path context)
+ (sb-c::compiler-error-context-original-source context))
+ (list :error "No error location available")))
+
+(defun locate-compiler-note (file source-path source)
+ (cond ((and (not (eq file :lisp)) *buffer-name*)
+ ;; Compiling from a buffer
+ (let ((position (+ *buffer-offset*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ (make-location (list :buffer *buffer-name*)
+ (list :position position))))
+ ((and (pathnamep file) (null *buffer-name*))
+ ;; Compiling from a file
+ (make-location (list :file (namestring file))
+ (list :position
+ (1+ (source-path-file-position
+ source-path file)))))
+ ((and (eq file :lisp) (stringp source))
+ ;; Compiling macro generated code
+ (make-location (list :source-form source)
+ (list :position 1)))
+ (t
+ (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
+
+(defun brief-compiler-message-for-emacs (condition)
+ "Briefly describe a compiler error for Emacs.
+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."
+ (let ((sb-int:*print-condition-references* nil))
+ (princ-to-string condition)))
+
+(defun long-compiler-message-for-emacs (condition error-context)
+ "Describe a compiler error for Emacs including context information."
+ (declare (type (or sb-c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (sb-c::compiler-error-context-enclosing-source error-context)
+ (sb-c::compiler-error-context-source error-context)))
+ (let ((sb-int:*print-condition-references* nil))
+ (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
+ enclosing source condition))))
+
+(defun compiler-source-path (context)
+ "Return the source-path for the current compiler error.
+Returns NIL if this cannot be determined by examining internal
+compiler state."
+ (cond ((sb-c::node-p context)
+ (reverse
+ (sb-c::source-path-original-source
+ (sb-c::node-source-path context))))
+ ((sb-c::compiler-error-context-p context)
+ (reverse
+ (sb-c::compiler-error-context-original-source-path context)))))
+
+(defimplementation call-with-compilation-hooks (function)
+ (declare (type function function))
+ (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
+ (sb-c:compiler-error #'handle-notification-condition)
+ (sb-ext:compiler-note #'handle-notification-condition)
+ (style-warning #'handle-notification-condition)
+ (warning #'handle-notification-condition))
+ (funcall function)))
+
+(defun handle-file-compiler-termination (condition)
+ "Handle a condition that caused the file compiler to terminate."
+ (handle-notification-condition
+ (sb-int:encapsulated-condition condition)))
+
+(defvar *trap-load-time-warnings* nil)
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (handler-case
+ (let ((output-file (with-compilation-hooks ()
+ (compile-file filename
+ :external-format external-format))))
+ (when output-file
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get filename (file-write-date filename))
+ (when load-p
+ (load output-file))))
+ (sb-c:fatal-compiler-error () nil)))
+
+;;;; compile-string
+
+;;; We copy the string to a temporary file in order to get adequate
+;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
+;;; which the previous approach using
+;;; (compile nil `(lambda () ,(read-from-string string)))
+;;; did not provide.
+
+(sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
+ (dest (* sb-alien:c-string)))
+
+(defun temp-file-name ()
+ "Return a temporary file name to compile strings into."
+ (concatenate 'string (tmpnam nil) ".lisp"))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (let ((*buffer-name* buffer)
+ (*buffer-offset* position)
+ (*buffer-substring* string)
+ (filename (temp-file-name)))
+ (flet ((compile-it (fn)
+ (with-compilation-hooks ()
+ (with-compilation-unit
+ (:source-plist (list :emacs-buffer buffer
+ :emacs-directory directory
+ :emacs-string string
+ :emacs-position position))
+ (funcall fn (compile-file filename))))))
+ (with-open-file (s filename :direction :output :if-exists :error)
+ (write-string string s))
+ (unwind-protect
+ (if *trap-load-time-warnings*
+ (compile-it #'load)
+ (load (compile-it #'identity)))
+ (ignore-errors
+ (delete-file filename)
+ (delete-file (compile-file-pathname filename)))))))
+
+;;;; Definitions
+
+(defvar *debug-definition-finding* nil
+ "When true don't handle errors while looking for definitions.
+This is useful when debugging the definition-finding code.")
+
+(defparameter *definition-types*
+ '(:variable defvar
+ :constant defconstant
+ :type deftype
+ :symbol-macro define-symbol-macro
+ :macro defmacro
+ :compiler-macro define-compiler-macro
+ :function defun
+ :generic-function defgeneric
+ :method defmethod
+ :setf-expander define-setf-expander
+ :structure defstruct
+ :condition define-condition
+ :class defclass
+ :method-combination define-method-combination
+ :package defpackage
+ :transform :deftransform
+ :optimizer :defoptimizer
+ :vop :define-vop
+ :source-transform :define-source-transform)
+ "Map SB-INTROSPECT definition type names to Slime-friendly forms")
+
+(defimplementation find-definitions (name)
+ (loop for type in *definition-types* by #'cddr
+ for locations = (sb-introspect:find-definition-sources-by-name
+ name type)
+ append (loop for source-location in locations collect
+ (make-source-location-specification type name
+ source-location))))
+
+(defun make-source-location-specification (type name source-location)
+ (list (list* (getf *definition-types* type)
+ name
+ (sb-introspect::definition-source-description source-location))
+ (if *debug-definition-finding*
+ (make-definition-source-location source-location type name)
+ (handler-case
+ (make-definition-source-location source-location type name)
+ (error (e)
+ (list :error (format nil "Error: ~A" e)))))))
+
+(defun make-definition-source-location (definition-source type name)
+ (with-struct (sb-introspect::definition-source-
+ pathname form-path character-offset plist
+ file-write-date)
+ definition-source
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
+ emacs-string &allow-other-keys)
+ plist
+ (cond
+ (emacs-buffer
+ (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
+ (pos (if form-path
+ (with-debootstrapping
+ (source-path-string-position form-path emacs-string))
+ character-offset))
+ (snippet (string-path-snippet emacs-string form-path pos)))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:position ,(+ pos emacs-position))
+ `(:snippet ,snippet))))
+ ((not pathname)
+ `(:error ,(format nil "Source of ~A ~A not found"
+ (string-downcase type) name)))
+ (t
+ (let* ((namestring (namestring (translate-logical-pathname pathname)))
+ (pos (source-file-position namestring file-write-date form-path
+ character-offset))
+ (snippet (source-hint-snippet namestring file-write-date pos)))
+ (make-location `(:file ,namestring)
+ `(:position ,pos)
+ `(:snippet ,snippet))))))))
+
+(defun string-path-snippet (string form-path position)
+ (if form-path
+ ;; If we have a form-path, use it to derive a more accurate
+ ;; snippet, so that we can point to the individual form rather
+ ;; than just the toplevel form.
+ (multiple-value-bind (data end)
+ (let ((*read-suppress* t))
+ (read-from-string string nil nil :start position))
+ (declare (ignore data))
+ (subseq string position end))
+ string))
+
+(defun source-file-position (filename write-date form-path character-offset)
+ (let ((source (get-source-code filename write-date))
+ (*readtable* (guess-readtable-for-filename filename)))
+ (1+ (with-debootstrapping
+ (if form-path
+ (source-path-string-position form-path source)
+ (or character-offset 0))))))
+
+(defun source-hint-snippet (filename write-date position)
+ (let ((source (get-source-code filename write-date)))
+ (with-input-from-string (s source)
+ (read-snippet s position))))
+
+(defun function-source-location (function &optional name)
+ (declare (type function function))
+ (let ((location (sb-introspect:find-definition-source function)))
+ (make-definition-source-location location :function name)))
+
+(defun safe-function-source-location (fun name)
+ (if *debug-definition-finding*
+ (function-source-location fun name)
+ (handler-case (function-source-location fun name)
+ (error (e)
+ (list :error (format nil "Error: ~A" e))))))
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ "Return a plist describing SYMBOL.
+Return NIL if the symbol is unbound."
+ (let ((result '()))
+ (flet ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (multiple-value-bind (kind recorded-p)
+ (sb-int:info :variable :kind symbol)
+ (declare (ignore kind))
+ (if (or (boundp symbol) recorded-p)
+ (doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((typep (fdefinition symbol) 'generic-function)
+ :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (if (or (sb-int:info :setf :inverse symbol)
+ (sb-int:info :setf :expander symbol))
+ (doc 'setf)))
+ (maybe-push
+ :type (if (sb-int:info :type :kind symbol)
+ (doc 'type)))
+ result)))
+
+(defimplementation describe-definition (symbol type)
+ (case type
+ (:variable
+ (describe symbol))
+ (:function
+ (describe (symbol-function symbol)))
+ (:setf
+ (describe (or (sb-int:info :setf :inverse symbol)
+ (sb-int:info :setf :expander symbol))))
+ (:class
+ (describe (find-class symbol)))
+ (:type
+ (describe (sb-kernel:values-specifier-type symbol)))))
+
+#+#.(swank-backend::sbcl-with-xref-p)
+(progn
+ (defmacro defxref (name)
+ `(defimplementation ,name (what)
+ (sanitize-xrefs
+ (mapcar #'source-location-for-xref-data
+ (,(find-symbol (symbol-name name) "SB-INTROSPECT")
+ what)))))
+ (defxref who-calls)
+ (defxref who-binds)
+ (defxref who-sets)
+ (defxref who-references)
+ (defxref who-macroexpands))
+
+(defun source-location-for-xref-data (xref-data)
+ (let ((name (car xref-data))
+ (source-location (cdr xref-data)))
+ (list name
+ (handler-case (make-definition-source-location source-location
+ 'function
+ name)
+ (error (e)
+ (list :error (format nil "Error: ~A" e)))))))
+
+(defimplementation list-callers (symbol)
+ (let ((fn (fdefinition symbol)))
+ (sanitize-xrefs
+ (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
+
+(defimplementation list-callees (symbol)
+ (let ((fn (fdefinition symbol)))
+ (sanitize-xrefs
+ (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
+
+(defun sanitize-xrefs (xrefs)
+ (remove-duplicates
+ (remove-if (lambda (f)
+ (member f (ignored-xref-function-names)))
+ (loop for entry in xrefs
+ for name = (car entry)
+ collect (if (and (consp name)
+ (member (car name)
+ '(sb-pcl::fast-method
+ sb-pcl::slow-method
+ sb-pcl::method)))
+ (cons (cons 'defmethod (cdr name))
+ (cdr entry))
+ entry))
+ :key #'car)
+ :test (lambda (a b)
+ (and (eq (first a) (first b))
+ (equal (second a) (second b))))))
+
+(defun ignored-xref-function-names ()
+ #-#.(swank-backend::sbcl-with-new-stepper-p)
+ '(nil sb-c::step-form sb-c::step-values)
+ #+#.(swank-backend::sbcl-with-new-stepper-p)
+ '(nil))
+
+(defun function-dspec (fn)
+ "Describe where the function FN was defined.
+Return a list of the form (NAME LOCATION)."
+ (let ((name (sb-kernel:%fun-name fn)))
+ (list name (safe-function-source-location fn name))))
+
+;;; macroexpansion
+
+(defimplementation macroexpand-all (form)
+ (let ((sb-walker:*walk-form-expand-macros-p* t))
+ (sb-walker:walk-form form)))
+
+
+;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation install-debugger-globally (function)
+ (setq sb-ext:*invoke-debugger-hook* function))
+
+(defimplementation condition-extras (condition)
+ (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
+ ((typep condition 'sb-impl::step-form-condition)
+ `((:show-frame-source 0)))
+ ((typep condition 'sb-int:reference-condition)
+ (let ((refs (sb-int:reference-condition-references condition)))
+ (if refs
+ `((:references ,(externalize-reference refs))))))))
+
+(defun externalize-reference (ref)
+ (etypecase ref
+ (null nil)
+ (cons (cons (externalize-reference (car ref))
+ (externalize-reference (cdr ref))))
+ ((or string number) ref)
+ (symbol
+ (cond ((eq (symbol-package ref) (symbol-package :test))
+ ref)
+ (t (symbol-name ref))))))
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (declare (type function debugger-loop-fn))
+ (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
+ (sb-debug:*stack-top-hint* nil))
+ (handler-bind ((sb-di:debug-condition
+ (lambda (condition)
+ (signal (make-condition
+ 'sldb-condition
+ :original-condition condition)))))
+ (funcall debugger-loop-fn))))
+
+#+#.(swank-backend::sbcl-with-new-stepper-p)
+(progn
+ (defimplementation activate-stepping (frame)
+ (declare (ignore frame))
+ (sb-impl::enable-stepping))
+ (defimplementation sldb-stepper-condition-p (condition)
+ (typep condition 'sb-ext:step-form-condition))
+ (defimplementation sldb-step-into ()
+ (invoke-restart 'sb-ext:step-into))
+ (defimplementation sldb-step-next ()
+ (invoke-restart 'sb-ext:step-next))
+ (defimplementation sldb-step-out ()
+ (invoke-restart 'sb-ext:step-out)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+ (let ((sb-ext:*invoke-debugger-hook* hook)
+ #+#.(swank-backend::sbcl-with-new-stepper-p)
+ (sb-ext:*stepper-hook*
+ (lambda (condition)
+ (typecase condition
+ (sb-ext:step-form-condition
+ (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
+ (sb-impl::invoke-debugger condition)))))))
+ (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
+ (sb-ext:step-condition #'sb-impl::invoke-stepper))
+ (funcall fun))))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation 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)))
+ (loop for f = (nth-frame start) then (sb-di:frame-down f)
+ for i from start below end
+ while f
+ collect f)))
+
+(defimplementation print-frame (frame stream)
+ (sb-debug::print-frame-call frame stream))
+
+;;;; Code-location -> source-location translation
+
+;;; If debug-block info is avaibale, we determine the file position of
+;;; the source-path for a code-location. If the code was compiled
+;;; with C-c C-c, we have to search the position in the source string.
+;;; If there's no debug-block info, we return the (less precise)
+;;; source-location of the corresponding function.
+
+(defun code-location-source-location (code-location)
+ (let* ((dsource (sb-di:code-location-debug-source code-location))
+ (plist (sb-c::debug-source-plist dsource)))
+ (if (getf plist :emacs-buffer)
+ (emacs-buffer-source-location code-location plist)
+ (ecase (sb-di:debug-source-from dsource)
+ (:file (file-source-location code-location))
+ (:lisp (lisp-source-location code-location))))))
+
+;;; FIXME: The naming policy of source-location functions is a bit
+;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
+;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
+;;; which returns the source location for a _code-location_.
+;;;
+;;; Maybe these should be named code-location-file-source-location,
+;;; etc, turned into generic functions, or something. In the very
+;;; least the names should indicate the main entry point vs. helper
+;;; status.
+
+(defun file-source-location (code-location)
+ (if (code-location-has-debug-block-info-p code-location)
+ (source-file-source-location code-location)
+ (fallback-source-location code-location)))
+
+(defun fallback-source-location (code-location)
+ (let ((fun (code-location-debug-fun-fun code-location)))
+ (cond (fun (function-source-location fun))
+ (t (error "Cannot find source location for: ~A " code-location)))))
+
+(defun lisp-source-location (code-location)
+ (let ((source (prin1-to-string
+ (sb-debug::code-location-source-form code-location 100))))
+ (make-location `(:source-form ,source) '(:position 0))))
+
+(defun emacs-buffer-source-location (code-location plist)
+ (if (code-location-has-debug-block-info-p code-location)
+ (destructuring-bind (&key emacs-buffer emacs-position emacs-string
+ &allow-other-keys)
+ plist
+ (let* ((pos (string-source-position code-location emacs-string))
+ (snipped (with-input-from-string (s emacs-string)
+ (read-snippet s pos))))
+ (make-location `(:buffer ,emacs-buffer)
+ `(:position ,(+ emacs-position pos))
+ `(:snippet ,snipped))))
+ (fallback-source-location code-location)))
+
+(defun source-file-source-location (code-location)
+ (let* ((code-date (code-location-debug-source-created code-location))
+ (filename (code-location-debug-source-name code-location))
+ (*readtable* (guess-readtable-for-filename filename))
+ (source-code (get-source-code filename code-date)))
+ (with-debootstrapping
+ (with-input-from-string (s source-code)
+ (let* ((pos (stream-source-position code-location s))
+ (snippet (read-snippet s pos)))
+ (make-location `(:file ,filename)
+ `(:position ,(1+ pos))
+ `(:snippet ,snippet)))))))
+
+(defun code-location-debug-source-name (code-location)
+ (namestring (truename (sb-c::debug-source-name
+ (sb-di::code-location-debug-source code-location)))))
+
+(defun code-location-debug-source-created (code-location)
+ (sb-c::debug-source-created
+ (sb-di::code-location-debug-source code-location)))
+
+(defun code-location-debug-fun-fun (code-location)
+ (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
+
+(defun code-location-has-debug-block-info-p (code-location)
+ (handler-case
+ (progn (sb-di:code-location-debug-block code-location)
+ t)
+ (sb-di:no-debug-blocks () nil)))
+
+(defun stream-source-position (code-location stream)
+ (let* ((cloc (sb-debug::maybe-block-start-location code-location))
+ (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
+ (form-number (sb-di::code-location-form-number cloc)))
+ (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
+ (let* ((path-table (sb-di::form-number-translations tlf 0))
+ (path (cond ((<= (length path-table) form-number)
+ (warn "inconsistent form-number-translations")
+ (list 0))
+ (t
+ (reverse (cdr (aref path-table form-number)))))))
+ (source-path-source-position path tlf pos-map)))))
+
+(defun string-source-position (code-location string)
+ (with-input-from-string (s string)
+ (stream-source-position code-location s)))
+
+;;; source-path-file-position and friends are in swank-source-path-parser
+
+(defun safe-source-location-for-emacs (code-location)
+ (if *debug-definition-finding*
+ (code-location-source-location code-location)
+ (handler-case (code-location-source-location code-location)
+ (error (c) (list :error (format nil "~A" c))))))
+
+(defimplementation frame-source-location-for-emacs (index)
+ (safe-source-location-for-emacs
+ (sb-di:frame-code-location (nth-frame index))))
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
+
+(defun debug-var-value (var frame location)
+ (ecase (sb-di:debug-var-validity var location)
+ (:valid (sb-di:debug-var-value var frame))
+ ((:invalid :unknown) ':<not-available>)))
+
+(defimplementation frame-locals (index)
+ (let* ((frame (nth-frame index))
+ (loc (sb-di:frame-code-location frame))
+ (vars (frame-debug-vars frame)))
+ (loop for v across vars collect
+ (list :name (sb-di:debug-var-symbol v)
+ :id (sb-di:debug-var-id v)
+ :value (debug-var-value v frame loc)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame (sb-di:frame-code-location frame))))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (sb-di:frame-catches (nth-frame index))))
+
+(defimplementation eval-in-frame (form index)
+ (let ((frame (nth-frame index)))
+ (funcall (the function
+ (sb-di:preprocess-for-eval form
+ (sb-di:frame-code-location frame)))
+ frame)))
+
+#+#.(swank-backend::sbcl-with-restart-frame)
+(progn
+ (defimplementation return-from-frame (index form)
+ (let* ((frame (nth-frame index)))
+ (cond ((sb-debug:frame-has-debug-tag-p frame)
+ (let ((values (multiple-value-list (eval-in-frame form index))))
+ (sb-debug:unwind-to-frame-and-call frame
+ (lambda ()
+ (values-list values)))))
+ (t (format nil "Cannot return from frame: ~S" frame)))))
+
+ (defimplementation restart-frame (index)
+ (let* ((frame (nth-frame index)))
+ (cond ((sb-debug:frame-has-debug-tag-p frame)
+ (let* ((call-list (sb-debug::frame-call-as-list frame))
+ (fun (fdefinition (car call-list)))
+ (thunk (lambda ()
+ ;; Ensure that the thunk gets tail-call-optimized
+ (declare (optimize (debug 1)))
+ (apply fun (cdr call-list)))))
+ (sb-debug:unwind-to-frame-and-call frame thunk)))
+ (t (format nil "Cannot restart frame: ~S" frame))))))
+
+;; FIXME: this implementation doesn't unwind the stack before
+;; re-invoking the function, but it's better than no implementation at
+;; all.
+#-#.(swank-backend::sbcl-with-restart-frame)
+(progn
+ (defun sb-debug-catch-tag-p (tag)
+ (and (symbolp tag)
+ (not (symbol-package tag))
+ (string= tag :sb-debug-catch-tag)))
+
+ (defimplementation return-from-frame (index form)
+ (let* ((frame (nth-frame index))
+ (probe (assoc-if #'sb-debug-catch-tag-p
+ (sb-di::frame-catches frame))))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame)))))
+
+ (defimplementation restart-frame (index)
+ (let ((frame (nth-frame index)))
+ (return-from-frame index (sb-debug::frame-call-as-list frame)))))
+
+;;;;; reference-conditions
+
+(defimplementation format-sldb-condition (condition)
+ (let ((sb-int:*print-condition-references* nil))
+ (princ-to-string condition)))
+
+
+;;;; Profiling
+
+(defimplementation profile (fname)
+ (when fname (eval `(sb-profile:profile ,fname))))
+
+(defimplementation unprofile (fname)
+ (when fname (eval `(sb-profile:unprofile ,fname))))
+
+(defimplementation unprofile-all ()
+ (sb-profile:unprofile)
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (sb-profile:report))
+
+(defimplementation profile-reset ()
+ (sb-profile:reset)
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ (sb-profile:profile))
+
+(defimplementation profile-package (package callers methods)
+ (declare (ignore callers methods))
+ (eval `(sb-profile:profile ,(package-name (find-package package)))))
+
+
+;;;; Inspector
+
+(defclass sbcl-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'sbcl-inspector))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (cond ((sb-di::indirect-value-cell-p o)
+ (values "A value cell." (label-value-line*
+ (:value (sb-kernel:value-cell-ref o)))))
+ (t
+ (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
+ (if label
+ (values text (loop for (l . v) in parts
+ append (label-value-line l v)))
+ (values text (loop for value in parts for i from 0
+ append (label-value-line i value))))))))
+
+(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (let ((header (sb-kernel:widetag-of o)))
+ (cond ((= header sb-vm:simple-fun-header-widetag)
+ (values "A simple-fun."
+ (label-value-line*
+ (:name (sb-kernel:%simple-fun-name o))
+ (:arglist (sb-kernel:%simple-fun-arglist o))
+ (:self (sb-kernel:%simple-fun-self o))
+ (:next (sb-kernel:%simple-fun-next o))
+ (:type (sb-kernel:%simple-fun-type o))
+ (:code (sb-kernel:fun-code-header o)))))
+ ((= header sb-vm:closure-header-widetag)
+ (values "A closure."
+ (append
+ (label-value-line :function (sb-kernel:%closure-fun o))
+ `("Closed over values:" (:newline))
+ (loop for i below (1- (sb-kernel:get-closure-length o))
+ append (label-value-line
+ i (sb-kernel:%closure-index-ref o i))))))
+ (t (call-next-method o)))))
+
+(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ backend-inspector))
+ (declare (ignore _))
+ (values (format nil "~A is a code data-block." o)
+ (append
+ (label-value-line*
+ (:code-size (sb-kernel:%code-code-size o))
+ (:entry-points (sb-kernel:%code-entry-points o))
+ (:debug-info (sb-kernel:%code-debug-info o))
+ (:trace-table-offset (sb-kernel:code-header-ref
+ o sb-vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from sb-vm:code-constants-offset
+ below (sb-kernel:get-header-data o)
+ append (label-value-line i (sb-kernel:code-header-ref o i)))
+ `("Code:" (:newline)
+ , (with-output-to-string (s)
+ (cond ((sb-kernel:%code-debug-info o)
+ (sb-disassem:disassemble-code-component o :stream s))
+ (t
+ (sb-disassem:disassemble-memory
+ (sb-disassem::align
+ (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
+ sb-vm:lowtag-mask)
+ (* sb-vm:code-constants-offset
+ sb-vm:n-word-bytes))
+ (ash 1 sb-vm:n-lowtag-bits))
+ (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
+ :stream s))))))))
+
+(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (values "A weak pointer."
+ (label-value-line*
+ (:value (sb-ext:weak-pointer-value o)))))
+
+(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (values "A fdefn object."
+ (label-value-line*
+ (:name (sb-kernel:fdefn-name o))
+ (:function (sb-kernel:fdefn-fun o)))))
+
+(defmethod inspect-for-emacs :around ((o generic-function)
+ (inspector backend-inspector))
+ (declare (ignore inspector))
+ (multiple-value-bind (title contents) (call-next-method)
+ (values title
+ (append
+ contents
+ (label-value-line*
+ (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
+ (:initial-methods (sb-pcl::generic-function-initial-methods o))
+ )))))
+
+
+;;;; Multiprocessing
+
+#+(and sb-thread
+ #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
+(progn
+ (defvar *thread-id-counter* 0)
+
+ (defvar *thread-id-counter-lock*
+ (sb-thread:make-mutex :name "thread id counter lock"))
+
+ (defun next-thread-id ()
+ (sb-thread:with-mutex (*thread-id-counter-lock*)
+ (incf *thread-id-counter*)))
+
+ (defparameter *thread-id-map* (make-hash-table))
+
+ ;; This should be a thread -> id map but as weak keys are not
+ ;; supported it is id -> map instead.
+ (defvar *thread-id-map-lock*
+ (sb-thread:make-mutex :name "thread id map lock"))
+
+ (defimplementation spawn (fn &key name)
+ (sb-thread:make-thread fn :name name))
+
+ (defimplementation thread-id (thread)
+ (block thread-id
+ (sb-thread:with-mutex (*thread-id-map-lock*)
+ (loop for id being the hash-key in *thread-id-map*
+ using (hash-value thread-pointer)
+ do
+ (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
+ (cond ((null maybe-thread)
+ ;; the value is gc'd, remove it manually
+ (remhash id *thread-id-map*))
+ ((eq thread maybe-thread)
+ (return-from thread-id id)))))
+ ;; lazy numbering
+ (let ((id (next-thread-id)))
+ (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
+ id))))
+
+ (defimplementation find-thread (id)
+ (sb-thread:with-mutex (*thread-id-map-lock*)
+ (let ((thread-pointer (gethash id *thread-id-map*)))
+ (if thread-pointer
+ (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
+ (if maybe-thread
+ maybe-thread
+ ;; the value is gc'd, remove it manually
+ (progn
+ (remhash id *thread-id-map*)
+ nil)))
+ nil))))
+
+ (defimplementation thread-name (thread)
+ ;; sometimes the name is not a string (e.g. NIL)
+ (princ-to-string (sb-thread:thread-name thread)))
+
+ (defimplementation thread-status (thread)
+ (if (sb-thread:thread-alive-p thread)
+ "RUNNING"
+ "STOPPED"))
+
+ (defimplementation make-lock (&key name)
+ (sb-thread:make-mutex :name name))
+
+ (defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (sb-thread:with-mutex (lock) (funcall function)))
+
+ (defimplementation make-recursive-lock (&key name)
+ (sb-thread:make-mutex :name name))
+
+ (defimplementation call-with-recursive-lock-held (lock function)
+ (declare (type function function))
+ (sb-thread:with-recursive-lock (lock) (funcall function)))
+
+ (defimplementation current-thread ()
+ sb-thread:*current-thread*)
+
+ (defimplementation all-threads ()
+ (sb-thread:list-all-threads))
+
+ (defimplementation interrupt-thread (thread fn)
+ (sb-thread:interrupt-thread thread fn))
+
+ (defimplementation kill-thread (thread)
+ (sb-thread:terminate-thread thread))
+
+ (defimplementation thread-alive-p (thread)
+ (sb-thread:thread-alive-p thread))
+
+ (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
+ (defvar *mailboxes* (list))
+ (declaim (type list *mailboxes*))
+
+ (defstruct (mailbox (:conc-name mailbox.))
+ thread
+ (mutex (sb-thread:make-mutex))
+ (waitqueue (sb-thread:make-waitqueue))
+ (queue '() :type list))
+
+ (defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (sb-thread:with-mutex (*mailbox-lock*)
+ (or (find thread *mailboxes* :key #'mailbox.thread)
+ (let ((mb (make-mailbox :thread thread)))
+ (push mb *mailboxes*)
+ mb))))
+
+ (defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (mutex (mailbox.mutex mbox)))
+ (sb-thread:with-mutex (mutex)
+ (setf (mailbox.queue mbox)
+ (nconc (mailbox.queue mbox) (list message)))
+ (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
+
+ (defimplementation receive ()
+ (let* ((mbox (mailbox (current-thread)))
+ (mutex (mailbox.mutex mbox)))
+ (sb-thread:with-mutex (mutex)
+ (loop
+ (let ((q (mailbox.queue mbox)))
+ (cond (q (return (pop (mailbox.queue mbox))))
+ (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
+ mutex))))))))
+
+
+ ;; Auto-flush streams
+
+ (defvar *auto-flush-interval* 0.15
+ "How often to flush interactive streams. This valu is passed
+ directly to cl:sleep.")
+
+ (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
+
+ (defvar *auto-flush-thread* nil)
+
+ (defvar *auto-flush-streams* '())
+
+ (defimplementation make-stream-interactive (stream)
+ (call-with-recursive-lock-held
+ *auto-flush-lock*
+ (lambda ()
+ (pushnew stream *auto-flush-streams*)
+ (unless *auto-flush-thread*
+ (setq *auto-flush-thread*
+ (sb-thread:make-thread #'flush-streams
+ :name "auto-flush-thread"))))))
+
+ (defun flush-streams ()
+ (loop
+ (call-with-recursive-lock-held
+ *auto-flush-lock*
+ (lambda ()
+ (setq *auto-flush-streams*
+ (remove-if (lambda (x)
+ (not (and (open-stream-p x)
+ (output-stream-p x))))
+ *auto-flush-streams*))
+ (mapc #'finish-output *auto-flush-streams*)))
+ (sleep *auto-flush-interval*)))
+
+ )
+
+(defimplementation quit-lisp ()
+ #+sb-thread
+ (dolist (thread (remove (current-thread) (all-threads)))
+ (ignore-errors (sb-thread:interrupt-thread
+ thread (lambda () (sb-ext:quit :recklessly-p t)))))
+ (sb-ext:quit))
+
+
+
+;;Trace implementations
+;;In SBCL, we have:
+;; (trace <name>)
+;; (trace :methods '<name>) ;to trace all methods of the gf <name>
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; <name> can be a normal name or a (setf name)
+
+(defun toggle-trace-aux (fspec &rest args)
+ (cond ((member fspec (eval '(trace)) :test #'equal)
+ (eval `(untrace ,fspec))
+ (format nil "~S is now untraced." fspec))
+ (t
+ (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
+ (format nil "~S is now traced." fspec))))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod) `(method ,@(rest fspec)))
+ ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
+ (t
+ fspec)))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defmethod)
+ (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
+ ((:defgeneric)
+ (toggle-trace-aux (second spec) :methods t))
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
+
+;;; Weak datastructures
+
+(defimplementation make-weak-key-hash-table (&rest args)
+ #+#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table :weakness :key args)
+ #-#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+ #+#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table :weakness :value args)
+ #-#.(swank-backend::sbcl-with-weak-hash-tables)
+ (apply #'make-hash-table args))
+
+(defimplementation hash-table-weakness (hashtable)
+ #+#.(swank-backend::sbcl-with-weak-hash-tables)
+ (sb-ext:hash-table-weakness hashtable))
Added: branches/bos/thirdparty/emacs/slime/swank-scl.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-scl.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,2072 @@
+;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
+;;;
+;;; Scieneer Common Lisp code for SLIME.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+
+(in-package :swank-backend)
+
+
+
+;;; swank-mop
+
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
+
+(defun swank-mop:slot-definition-documentation (slot)
+ (documentation slot t))
+
+
+;;;; TCP server
+;;;
+;;; SCL only supports the :spawn communication style.
+;;;
+
+(defimplementation preferred-communication-style ()
+ :spawn)
+
+(defimplementation create-socket (host port)
+ (let ((addr (resolve-hostname host)))
+ (ext:create-inet-listener port :stream :host addr :reuse-address t)))
+
+(defimplementation local-port (socket)
+ (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
+
+(defimplementation close-socket (socket)
+ (ext:close-socket (socket-fd socket)))
+
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
+ (let ((external-format (or external-format :default))
+ (buffering (or buffering :full))
+ (fd (socket-fd socket)))
+ (loop
+ (let ((ready (sys:wait-until-fd-usable fd :input timeout)))
+ (unless ready
+ (error "Timeout accepting connection on socket: ~S~%" socket)))
+ (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
+ (when new-fd
+ (return (make-socket-io-stream new-fd external-format buffering)))))))
+
+(defimplementation set-stream-timeout (stream timeout)
+ (check-type timeout (or null real))
+ (if (fboundp 'ext::stream-timeout)
+ (setf (ext::stream-timeout stream) timeout)
+ (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout)
+ timeout)))
+
+;;;;; Sockets
+
+(defun socket-fd (socket)
+ "Return the file descriptor for the socket represented by 'socket."
+ (etypecase socket
+ (fixnum socket)
+ (stream (sys:fd-stream-fd socket))))
+
+(defun resolve-hostname (hostname)
+ "Return the IP address of 'hostname as an integer (in host byte-order)."
+ (let ((hostent (ext:lookup-host-entry hostname)))
+ (car (ext:host-entry-addr-list hostent))))
+
+(defvar *external-format-to-coding-system*
+ '((:iso-8859-1
+ "latin-1" "latin-1-unix" "iso-latin-1-unix"
+ "iso-8859-1" "iso-8859-1-unix")
+ (:utf-8 "utf-8" "utf-8-unix")
+ (:euc-jp "euc-jp" "euc-jp-unix")))
+
+(defimplementation find-external-format (coding-system)
+ (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+ *external-format-to-coding-system*)))
+
+(defun make-socket-io-stream (fd external-format buffering)
+ "Create a new input/output fd-stream for 'fd."
+ (let* ((stream (sys:make-fd-stream fd :input t :output t
+ :element-type 'base-char
+ :buffering buffering
+ :external-format external-format)))
+ ;; Ignore character conversion errors. Without this the communication
+ ;; channel is prone to lockup if a character conversion error occurs.
+ (setf (lisp::character-conversion-stream-input-error-value stream) #\?)
+ (setf (lisp::character-conversion-stream-output-error-value stream) #\?)
+ stream))
+
+
+;;;; Stream handling
+
+(defclass slime-input-stream (ext:character-input-stream)
+ ((buffer :initarg :buffer :type string)
+ (index :initarg :index :initform 0 :type fixnum)
+ (position :initarg :position :initform 0 :type integer)
+ (interactive :initarg :interactive :initform nil :type (member nil t))
+ (output-stream :initarg :output-stream :initform nil)
+ (input-fn :initarg :input-fn :type function)
+ ))
+
+(defun make-slime-input-stream (input-fn &optional output-stream)
+ (declare (function input-fn))
+ (make-instance 'slime-input-stream
+ :in-buffer (make-string 256)
+ :in-head 0 :in-tail 0
+ :out-buffer ""
+ :buffer "" :index 0
+ :input-fn input-fn
+ :output-stream output-stream))
+
+(defmethod print-object ((s slime-input-stream) stream)
+ (print-unreadable-object (s stream :type t)))
+
+;;; input-stream-p inherits from input-stream.
+;;; output-stream-p inherits nil.
+
+(defmethod ext:stream-listen ((stream slime-input-stream))
+ (let* ((buffer (slot-value stream 'buffer))
+ (index (slot-value stream 'index))
+ (length (length buffer)))
+ (declare (type string buffer)
+ (fixnum index length))
+ (< index length)))
+
+(defmethod close ((stream slime-input-stream) &key ((:abort abort) nil))
+ (declare (ignore abort))
+ (when (ext:stream-open-p stream)
+ (setf (ext:stream-open-p stream) nil)
+ (setf (ext:stream-in-buffer stream) " ")
+ t))
+
+(defmethod ext:stream-clear-input ((stream slime-input-stream))
+ (let* ((input-buffer (slot-value stream 'buffer))
+ (index (slot-value stream 'index))
+ (input-length (length input-buffer))
+ (available (- input-length index))
+ (position (slot-value stream 'position))
+ (new-position (+ position available)))
+ (declare (type kernel:index index available position new-position))
+ (setf (slot-value stream 'position) new-position))
+ (setf (slot-value stream 'buffer) "")
+ (setf (slot-value stream 'index) 0)
+ nil)
+
+;;; No 'stream-finish-output method.
+;;; No 'stream-force-output method.
+;;; No 'stream-clear-output method.
+
+;;; stream-element-type inherits from character-stream.
+
+;;; No 'stream-line-length method.
+;;; No 'stream-line-column method.
+
+;;; Add the remaining input to the current position.
+(defmethod file-length ((stream slime-input-stream))
+ (let* ((input-buffer (slot-value stream 'buffer))
+ (index (slot-value stream 'index))
+ (input-length (length input-buffer))
+ (available (- input-length index))
+ (position (slot-value stream 'position))
+ (file-length (+ position available)))
+ (declare (type kernel:index index available position file-length))
+ file-length))
+
+(defmethod ext:stream-file-position ((stream slime-input-stream)
+ &optional position)
+ (let ((current-position (slot-value stream 'position)))
+ (declare (type kernel:index current-position))
+ (cond (position
+ ;; Could make an attempt here, but just give up for now.
+ nil)
+ (t
+ current-position))))
+
+(defmethod interactive-stream-p ((stream slime-input-stream))
+ (slot-value stream 'interactive))
+
+;;; No 'file-string-length method.
+
+(defmethod ext:stream-read-chars ((stream slime-input-stream) buffer
+ start requested waitp)
+ (declare (type simple-string buffer)
+ (type kernel:index start requested))
+ (let* ((input-buffer (slot-value stream 'buffer))
+ (index (slot-value stream 'index))
+ (input-length (length input-buffer))
+ (available (- input-length index))
+ (copy (min available requested)))
+ (declare (string input-buffer)
+ (type kernel:index index available copy))
+ (cond ((plusp copy)
+ (dotimes (i copy)
+ (declare (type kernel:index i))
+ (setf (aref buffer (+ start i)) (aref input-buffer (+ index i))))
+ (setf (slot-value stream 'index) (+ index copy))
+ (incf (slot-value stream 'position) copy)
+ copy)
+ (waitp
+ (let ((output-stream (slot-value stream 'output-stream))
+ (input-fn (slot-value stream 'input-fn)))
+ (declare (type function input-fn))
+ (when output-stream
+ (force-output output-stream))
+ (let ((new-input (funcall input-fn)))
+ (cond ((zerop (length new-input))
+ -1)
+ (t
+ (setf (slot-value stream 'buffer) new-input)
+ (setf (slot-value stream 'index) 0)
+ (ext:stream-read-chars stream buffer
+ start requested waitp))))))
+ (t
+ 0))))
+
+;;; Slime output stream.
+
+(defclass slime-output-stream (ext:character-output-stream)
+ ((output-fn :initarg :output-fn :type function)
+ (column :initform 0 :type kernel:index)
+ (interactive :initform nil :type (member nil t))
+ (position :initform 0 :type integer)))
+
+(defun make-slime-output-stream (output-fn)
+ (declare (function output-fn))
+ (make-instance 'slime-output-stream
+ :in-buffer ""
+ :out-buffer (make-string 256)
+ :output-fn output-fn))
+
+(defmethod print-object ((s slime-output-stream) stream)
+ (print-unreadable-object (s stream :type t)))
+
+;;; Use default 'input-stream-p method for 'output-stream which returns 'nil.
+;;; Use default 'output-stream-p method for 'output-stream which returns 't.
+
+;;; No 'stream-listen method.
+
+(defmethod close ((stream slime-output-stream) &key ((:abort abort) nil))
+ (when (ext:stream-open-p stream)
+ (unless abort
+ (finish-output stream))
+ (setf (ext:stream-open-p stream) nil)
+ (setf (ext:stream-out-buffer stream) " ")
+ t))
+
+;;; No 'stream-clear-input method.
+
+(defmethod ext:stream-finish-output ((stream slime-output-stream))
+ nil)
+
+(defmethod ext:stream-force-output ((stream slime-output-stream))
+ nil)
+
+(defmethod ext:stream-clear-output ((stream slime-output-stream))
+ nil)
+
+;;; Use default 'stream-element-type method for 'character-stream which
+;;; returns 'base-char.
+
+(defmethod ext:stream-line-length ((stream slime-output-stream))
+ 80)
+
+(defmethod ext:stream-line-column ((stream slime-output-stream))
+ (slot-value stream 'column))
+
+(defmethod file-length ((stream slime-output-stream))
+ (slot-value stream 'position))
+
+(defmethod ext:stream-file-position ((stream slime-output-stream)
+ &optional position)
+ (declare (optimize (speed 3)))
+ (cond (position
+ (let* ((current-position (slot-value stream 'position))
+ (target-position (etypecase position
+ ((member :start) 0)
+ ((member :end) current-position)
+ (kernel:index position))))
+ (declare (type kernel:index current-position target-position))
+ (cond ((= target-position current-position)
+ t)
+ ((> target-position current-position)
+ (let ((output-fn (slot-value stream 'output-fn))
+ (fill-size (- target-position current-position)))
+ (declare (function output-fn))
+ (funcall output-fn (make-string fill-size
+ :initial-element #\space))
+ (setf (slot-value stream 'position) target-position))
+ t)
+ (t
+ nil))))
+ (t
+ (slot-value stream 'position))))
+
+(defmethod interactive-stream-p ((stream slime-output-stream))
+ (slot-value stream 'interactive))
+
+;;; Use the default 'character-output-stream 'file-string-length method.
+
+;;; stream-write-chars
+;;;
+;;; The stream out-buffer is typically large enough that there is little point
+;;; growing the stream output 'string large than the total size. For typical
+;;; usage this reduces consing. As the string grows larger then grow to
+;;; reduce the cost of copying strings around.
+;;;
+(defmethod ext:stream-write-chars ((stream slime-output-stream)
+ string start end waitp)
+ (declare (simple-string string)
+ (type kernel:index start end)
+ (ignore waitp))
+ (declare (optimize (speed 3)))
+ (unless (ext:stream-open-p stream)
+ (error 'kernel:simple-stream-error
+ :stream stream
+ :format-control "Stream closed."))
+ (let* ((string-length (length string))
+ (start (cond ((< start 0) 0)
+ ((> start string-length) string-length)
+ (t start)))
+ (end (cond ((< end start) start)
+ ((> end string-length) string-length)
+ (t end)))
+ (length (- end start))
+ (output-fn (slot-value stream 'output-fn)))
+ (declare (type kernel:index start end length)
+ (type function output-fn))
+ (unless (zerop length)
+ (funcall output-fn (subseq string start end))
+ (let ((last-newline (position #\newline string :from-end t
+ :start start :end end)))
+ (setf (slot-value stream 'column)
+ (if last-newline
+ (- end last-newline 1)
+ (let ((column (slot-value stream 'column)))
+ (declare (type kernel:index column))
+ (+ column (- end start))))))))
+ (- end start))
+
+;;;
+
+(defimplementation 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)))
+
+(defimplementation make-stream-interactive (stream)
+ (when (or (typep stream 'slime-input-stream)
+ (typep stream 'slime-output-stream))
+ (setf (slot-value stream 'interactive) t)))
+
+
+;;;; Compilation Commands
+
+(defvar *previous-compiler-condition* nil
+ "Used to detect duplicates.")
+
+(defvar *previous-context* nil
+ "Previous compiler error context.")
+
+(defvar *buffer-name* nil
+ "The name of the Emacs buffer we are compiling from.
+ Nil if we aren't compiling from a buffer.")
+
+(defvar *buffer-start-position* nil)
+(defvar *buffer-substring* nil)
+
+(defimplementation call-with-compilation-hooks (function)
+ (let ((*previous-compiler-condition* nil)
+ (*previous-context* nil)
+ (*print-readably* nil))
+ (handler-bind ((c::compiler-error #'handle-notification-condition)
+ (c::style-warning #'handle-notification-condition)
+ (c::warning #'handle-notification-condition))
+ (funcall function))))
+
+(defimplementation swank-compile-file (filename load-p external-format)
+ (with-compilation-hooks ()
+ (let ((*buffer-name* nil)
+ (ext:*ignore-extra-close-parentheses* nil))
+ (multiple-value-bind (output-file warnings-p failure-p)
+ (compile-file filename :external-format external-format)
+ (unless failure-p
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get filename (file-write-date filename))
+ (when load-p (load output-file)))
+ (values output-file warnings-p failure-p)))))
+
+(defimplementation swank-compile-string (string &key buffer position directory)
+ (declare (ignore directory))
+ (with-compilation-hooks ()
+ (let ((*buffer-name* buffer)
+ (*buffer-start-position* position)
+ (*buffer-substring* string))
+ (with-input-from-string (stream string)
+ (ext:compile-from-stream
+ stream
+ :source-info `(:emacs-buffer ,buffer
+ :emacs-buffer-offset ,position
+ :emacs-buffer-string ,string))))))
+
+
+;;;;; Trapping notes
+;;;
+;;; We intercept conditions from the compiler and resignal them as
+;;; `swank:compiler-condition's.
+
+(defun handle-notification-condition (condition)
+ "Handle a condition caused by a compiler warning."
+ (unless (eq condition *previous-compiler-condition*)
+ (let ((context (c::find-error-context nil)))
+ (setq *previous-compiler-condition* condition)
+ (setq *previous-context* context)
+ (signal-compiler-condition condition context))))
+
+(defun signal-compiler-condition (condition context)
+ (signal (make-condition
+ 'compiler-condition
+ :original-condition condition
+ :severity (severity-for-emacs condition)
+ :short-message (brief-compiler-message-for-emacs condition)
+ :message (long-compiler-message-for-emacs condition context)
+ :location (if (read-error-p condition)
+ (read-error-location condition)
+ (compiler-note-location context)))))
+
+(defun severity-for-emacs (condition)
+ "Return the severity of 'condition."
+ (etypecase condition
+ ((satisfies read-error-p) :read-error)
+ (c::compiler-error :error)
+ (c::style-warning :note)
+ (c::warning :warning)))
+
+(defun read-error-p (condition)
+ (eq (type-of condition) 'c::compiler-read-error))
+
+(defun brief-compiler-message-for-emacs (condition)
+ "Briefly describe a compiler error for Emacs.
+ 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."
+ (princ-to-string condition))
+
+(defun long-compiler-message-for-emacs (condition error-context)
+ "Describe a compiler error for Emacs including context information."
+ (declare (type (or c::compiler-error-context null) error-context))
+ (multiple-value-bind (enclosing source)
+ (if error-context
+ (values (c::compiler-error-context-enclosing-source error-context)
+ (c::compiler-error-context-source error-context)))
+ (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
+ enclosing source condition)))
+
+(defun read-error-location (condition)
+ (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
+ (file (c::file-info-name finfo))
+ (pos (c::compiler-read-error-position condition)))
+ (cond ((and (eq file :stream) *buffer-name*)
+ (make-location (list :buffer *buffer-name*)
+ (list :position (+ *buffer-start-position* pos))))
+ ((and (pathnamep file) (not *buffer-name*))
+ (make-location (list :file (unix-truename file))
+ (list :position (1+ pos))))
+ (t (break)))))
+
+(defun compiler-note-location (context)
+ "Derive the location of a complier message from its context.
+ Return a `location' record, or (:error <reason>) on failure."
+ (if (null context)
+ (note-error-location)
+ (let ((file (c::compiler-error-context-file-name context))
+ (source (c::compiler-error-context-original-source context))
+ (path
+ (reverse (c::compiler-error-context-original-source-path context))))
+ (or (locate-compiler-note file source path)
+ (note-error-location)))))
+
+(defun note-error-location ()
+ "Pseudo-location for notes that can't be located."
+ (list :error "No error location available."))
+
+(defun locate-compiler-note (file source source-path)
+ (cond ((and (eq file :stream) *buffer-name*)
+ ;; Compiling from a buffer
+ (let ((position (+ *buffer-start-position*
+ (source-path-string-position
+ source-path *buffer-substring*))))
+ (make-location (list :buffer *buffer-name*)
+ (list :position position))))
+ ((and (pathnamep file) (null *buffer-name*))
+ ;; Compiling from a file
+ (make-location (list :file (unix-truename file))
+ (list :position
+ (1+ (source-path-file-position
+ source-path file)))))
+ ((and (eq file :lisp) (stringp source))
+ ;; No location known, but we have the source form.
+ ;; XXX How is this case triggered? -luke (16/May/2004)
+ ;; This can happen if the compiler needs to expand a macro
+ ;; but the macro-expander is not yet compiled. Calling the
+ ;; (interpreted) macro-expander triggers IR1 conversion of
+ ;; the lambda expression for the expander and invokes the
+ ;; compiler recursively.
+ (make-location (list :source-form source)
+ (list :position 1)))))
+
+(defun unix-truename (pathname)
+ (ext:unix-namestring (truename pathname)))
+
+
+
+;;; TODO
+(defimplementation who-calls (name) nil)
+(defimplementation who-references (name) nil)
+(defimplementation who-binds (name) nil)
+(defimplementation who-sets (name) nil)
+(defimplementation who-specializes (symbol) nil)
+(defimplementation who-macroexpands (name) nil)
+
+
+;;;; Find callers and callees
+;;;
+;;; Find callers and callees by looking at the constant pool of
+;;; compiled code objects. We assume every fdefn object in the
+;;; constant pool corresponds to a call to that function. A better
+;;; strategy would be to use the disassembler to find actual
+;;; call-sites.
+
+(declaim (inline map-code-constants))
+(defun map-code-constants (code fn)
+ "Call 'fn for each constant in 'code's constant pool."
+ (check-type code kernel:code-component)
+ (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
+ do (funcall fn (kernel:code-header-ref code i))))
+
+(defun function-callees (function)
+ "Return 'function's callees as a list of functions."
+ (let ((callees '()))
+ (map-code-constants
+ (vm::find-code-object function)
+ (lambda (obj)
+ (when (kernel:fdefn-p obj)
+ (push (kernel:fdefn-function obj) callees))))
+ callees))
+
+(declaim (ext:maybe-inline map-allocated-code-components))
+(defun map-allocated-code-components (spaces fn)
+ "Call FN for each allocated code component in one of 'spaces. FN
+ receives the object as argument. 'spaces should be a list of the
+ symbols :dynamic, :static, or :read-only."
+ (dolist (space spaces)
+ (declare (inline vm::map-allocated-objects)
+ (optimize (ext:inhibit-warnings 3)))
+ (vm::map-allocated-objects
+ (lambda (obj header size)
+ (declare (type fixnum size) (ignore size))
+ (when (= vm:code-header-type header)
+ (funcall fn obj)))
+ space)))
+
+(declaim (ext:maybe-inline map-caller-code-components))
+(defun map-caller-code-components (function spaces fn)
+ "Call 'fn for each code component with a fdefn for 'function in its
+ constant pool."
+ (let ((function (coerce function 'function)))
+ (declare (inline map-allocated-code-components))
+ (map-allocated-code-components
+ spaces
+ (lambda (obj)
+ (map-code-constants
+ obj
+ (lambda (constant)
+ (when (and (kernel:fdefn-p constant)
+ (eq (kernel:fdefn-function constant)
+ function))
+ (funcall fn obj))))))))
+
+(defun function-callers (function &optional (spaces '(:read-only :static
+ :dynamic)))
+ "Return 'function's callers. The result is a list of code-objects."
+ (let ((referrers '()))
+ (declare (inline map-caller-code-components))
+ (map-caller-code-components function spaces
+ (lambda (code) (push code referrers)))
+ referrers))
+
+(defun debug-info-definitions (debug-info)
+ "Return the defintions for a debug-info. This should only be used
+ for code-object without entry points, i.e., byte compiled
+ code (are theree others?)"
+ ;; This mess has only been tested with #'ext::skip-whitespace, a
+ ;; byte-compiled caller of #'read-char .
+ (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
+ (let ((name (c::debug-info-name debug-info))
+ (source (c::debug-info-source debug-info)))
+ (destructuring-bind (first) source
+ (ecase (c::debug-source-from first)
+ (:file
+ (list (list name
+ (make-location
+ (list :file (unix-truename (c::debug-source-name first)))
+ (list :function-name (string name))))))))))
+
+(defun valid-function-name-p (name)
+ (or (symbolp name) (and (consp name)
+ (eq (car name) 'setf)
+ (symbolp (cadr name))
+ (not (cddr name)))))
+
+(defun code-component-entry-points (code)
+ "Return a list ((name location) ...) of function definitons for
+ the code omponent 'code."
+ (let ((names '()))
+ (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
+ ((not f))
+ (let ((name (kernel:%function-name f)))
+ (when (valid-function-name-p name)
+ (push (list name (function-location f)) names))))
+ names))
+
+(defimplementation list-callers (symbol)
+ "Return a list ((name location) ...) of callers."
+ (let ((components (function-callers symbol))
+ (xrefs '()))
+ (dolist (code components)
+ (let* ((entry (kernel:%code-entry-points code))
+ (defs (if entry
+ (code-component-entry-points code)
+ ;; byte compiled stuff
+ (debug-info-definitions
+ (kernel:%code-debug-info code)))))
+ (setq xrefs (nconc defs xrefs))))
+ xrefs))
+
+(defimplementation list-callees (symbol)
+ (let ((fns (function-callees symbol)))
+ (mapcar (lambda (fn)
+ (list (kernel:%function-name fn)
+ (function-location fn)))
+ fns)))
+
+
+;;;; Resolving source locations
+;;;
+;;; Our mission here is to "resolve" references to code locations into
+;;; actual file/buffer names and character positions. The references
+;;; we work from come out of the compiler's statically-generated debug
+;;; information, such as `code-location''s and `debug-source''s. For
+;;; more details, see the "Debugger Programmer's Interface" section of
+;;; the SCL manual.
+;;;
+;;; The first step is usually to find the corresponding "source-path"
+;;; for the location. Once we have the source-path we can pull up the
+;;; source file and `READ' our way through to the right position. The
+;;; main source-code groveling work is done in
+;;; `swank-source-path-parser.lisp'.
+
+(defvar *debug-definition-finding* nil
+ "When true don't handle errors while looking for definitions.
+ This is useful when debugging the definition-finding code.")
+
+(defvar *source-snippet-size* 256
+ "Maximum number of characters in a snippet of source code.
+ Snippets at the beginning of definitions are used to tell Emacs what
+ the definitions looks like, so that it can accurately find them by
+ text search.")
+
+(defmacro safe-definition-finding (&body body)
+ "Execute 'body and return the source-location it returns.
+ If an error occurs and `*debug-definition-finding*' is false, then
+ return an error pseudo-location.
+
+ The second return value is 'nil if no error occurs, otherwise it is the
+ condition object."
+ `(flet ((body () ,@body))
+ (if *debug-definition-finding*
+ (body)
+ (handler-case (values (progn ,@body) nil)
+ (error (c) (values (list :error (princ-to-string c)) c))))))
+
+(defun code-location-source-location (code-location)
+ "Safe wrapper around `code-location-from-source-location'."
+ (safe-definition-finding
+ (source-location-from-code-location code-location)))
+
+(defun source-location-from-code-location (code-location)
+ "Return the source location for 'code-location."
+ (let ((debug-fun (di:code-location-debug-function code-location)))
+ (when (di::bogus-debug-function-p debug-fun)
+ ;; Those lousy cheapskates! They've put in a bogus debug source
+ ;; because the code was compiled at a low debug setting.
+ (error "Bogus debug function: ~A" debug-fun)))
+ (let* ((debug-source (di:code-location-debug-source code-location))
+ (from (di:debug-source-from debug-source))
+ (name (di:debug-source-name debug-source)))
+ (ecase from
+ (:file
+ (location-in-file name code-location debug-source))
+ (:stream
+ (location-in-stream code-location debug-source))
+ (:lisp
+ ;; The location comes from a form passed to `compile'.
+ ;; The best we can do is return the form itself for printing.
+ (make-location
+ (list :source-form (with-output-to-string (*standard-output*)
+ (debug::print-code-location-source-form
+ code-location 100 t)))
+ (list :position 1))))))
+
+(defun location-in-file (filename code-location debug-source)
+ "Resolve the source location for 'code-location in 'filename."
+ (let* ((code-date (di:debug-source-created debug-source))
+ (source-code (get-source-code filename code-date)))
+ (with-input-from-string (s source-code)
+ (make-location (list :file (unix-truename filename))
+ (list :position (1+ (code-location-stream-position
+ code-location s)))
+ `(:snippet ,(read-snippet s))))))
+
+(defun location-in-stream (code-location debug-source)
+ "Resolve the source location for a 'code-location from a stream.
+ This only succeeds if the code was compiled from an Emacs buffer."
+ (unless (debug-source-info-from-emacs-buffer-p debug-source)
+ (error "The code is compiled from a non-SLIME stream."))
+ (let* ((info (c::debug-source-info debug-source))
+ (string (getf info :emacs-buffer-string))
+ (position (code-location-string-offset
+ code-location
+ string)))
+ (make-location
+ (list :buffer (getf info :emacs-buffer))
+ (list :position (+ (getf info :emacs-buffer-offset) position))
+ (list :snippet (with-input-from-string (s string)
+ (file-position s position)
+ (read-snippet s))))))
+
+;;;;; Function-name locations
+;;;
+(defun debug-info-function-name-location (debug-info)
+ "Return a function-name source-location for 'debug-info.
+ Function-name source-locations are a fallback for when precise
+ positions aren't available."
+ (with-struct (c::debug-info- (fname name) source) debug-info
+ (with-struct (c::debug-source- info from name) (car source)
+ (ecase from
+ (:file
+ (make-location (list :file (namestring (truename name)))
+ (list :function-name (string fname))))
+ (:stream
+ (assert (debug-source-info-from-emacs-buffer-p (car source)))
+ (make-location (list :buffer (getf info :emacs-buffer))
+ (list :function-name (string fname))))
+ (:lisp
+ (make-location (list :source-form (princ-to-string (aref name 0)))
+ (list :position 1)))))))
+
+(defun debug-source-info-from-emacs-buffer-p (debug-source)
+ "Does the `info' slot of 'debug-source contain an Emacs buffer location?
+ This is true for functions that were compiled directly from buffers."
+ (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
+
+(defun info-from-emacs-buffer-p (info)
+ (and info
+ (consp info)
+ (eq :emacs-buffer (car info))))
+
+
+;;;;; Groveling source-code for positions
+
+(defun code-location-stream-position (code-location stream)
+ "Return the byte offset of 'code-location in 'stream. Extract the
+ toplevel-form-number and form-number from 'code-location and use that
+ to find the position of the corresponding form.
+
+ Finish with 'stream positioned at the start of the code location."
+ (let* ((location (debug::maybe-block-start-location code-location))
+ (tlf-offset (di:code-location-top-level-form-offset location))
+ (form-number (di:code-location-form-number location)))
+ (let ((pos (form-number-stream-position tlf-offset form-number stream)))
+ (file-position stream pos)
+ pos)))
+
+(defun form-number-stream-position (tlf-number form-number stream)
+ "Return the starting character position of a form in 'stream.
+ 'tlf-number is the top-level-form number.
+ 'form-number is an index into a source-path table for the TLF."
+ (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
+ (let* ((path-table (di:form-number-translations tlf 0))
+ (source-path
+ (if (<= (length path-table) form-number) ; source out of sync?
+ (list 0) ; should probably signal a condition
+ (reverse (cdr (aref path-table form-number))))))
+ (source-path-source-position source-path tlf position-map))))
+
+(defun code-location-string-offset (code-location string)
+ "Return the byte offset of 'code-location in 'string.
+ See 'code-location-stream-position."
+ (with-input-from-string (s string)
+ (code-location-stream-position code-location s)))
+
+
+;;;; Finding definitions
+
+;;; There are a great many different types of definition for us to
+;;; find. We search for definitions of every kind and return them in a
+;;; list.
+
+(defimplementation find-definitions (name)
+ (append (function-definitions name)
+ (setf-definitions name)
+ (variable-definitions name)
+ (class-definitions name)
+ (type-definitions name)
+ (compiler-macro-definitions name)
+ (source-transform-definitions name)
+ (function-info-definitions name)
+ (ir1-translator-definitions name)))
+
+;;;;; Functions, macros, generic functions, methods
+;;;
+;;; We make extensive use of the compile-time debug information that
+;;; SCL records, in particular "debug functions" and "code
+;;; locations." Refer to the "Debugger Programmer's Interface" section
+;;; of the SCL manual for more details.
+
+(defun function-definitions (name)
+ "Return definitions for 'name in the \"function namespace\", i.e.,
+ regular functions, generic functions, methods and macros.
+ 'name can any valid function name (e.g, (setf car))."
+ (let ((macro? (and (symbolp name) (macro-function name)))
+ (special? (and (symbolp name) (special-operator-p name)))
+ (function? (and (valid-function-name-p name)
+ (ext:info :function :definition name)
+ (if (symbolp name) (fboundp name) t))))
+ (cond (macro?
+ (list `((defmacro ,name)
+ ,(function-location (macro-function name)))))
+ (special?
+ (list `((:special-operator ,name)
+ (:error ,(format nil "Special operator: ~S" name)))))
+ (function?
+ (let ((function (fdefinition name)))
+ (if (genericp function)
+ (generic-function-definitions name function)
+ (list (list `(function ,name)
+ (function-location function)))))))))
+
+;;;;;; Ordinary (non-generic/macro/special) functions
+;;;
+;;; First we test if FUNCTION is a closure created by defstruct, and
+;;; if so extract the defstruct-description (`dd') from the closure
+;;; and find the constructor for the struct. Defstruct creates a
+;;; defun for the default constructor and we use that as an
+;;; approximation to the source location of the defstruct.
+;;;
+;;; For an ordinary function we return the source location of the
+;;; first code-location we find.
+;;;
+(defun function-location (function)
+ "Return the source location for FUNCTION."
+ (cond ((struct-closure-p function)
+ (struct-closure-location function))
+ ((c::byte-function-or-closure-p function)
+ (byte-function-location function))
+ (t
+ (compiled-function-location function))))
+
+(defun compiled-function-location (function)
+ "Return the location of a regular compiled function."
+ (multiple-value-bind (code-location error)
+ (safe-definition-finding (function-first-code-location function))
+ (cond (error (list :error (princ-to-string error)))
+ (t (code-location-source-location code-location)))))
+
+(defun function-first-code-location (function)
+ "Return the first code-location we can find for 'function."
+ (and (function-has-debug-function-p function)
+ (di:debug-function-start-location
+ (di:function-debug-function function))))
+
+(defun function-has-debug-function-p (function)
+ (di:function-debug-function function))
+
+(defun function-code-object= (closure function)
+ (and (eq (vm::find-code-object closure)
+ (vm::find-code-object function))
+ (not (eq closure function))))
+
+
+(defun byte-function-location (fn)
+ "Return the location of the byte-compiled function 'fn."
+ (etypecase fn
+ ((or c::hairy-byte-function c::simple-byte-function)
+ (let* ((component (c::byte-function-component fn))
+ (debug-info (kernel:%code-debug-info component)))
+ (debug-info-function-name-location debug-info)))
+ (c::byte-closure
+ (byte-function-location (c::byte-closure-function fn)))))
+
+;;; Here we deal with structure accessors. Note that `dd' is a
+;;; "defstruct descriptor" structure in SCL. A `dd' describes a
+;;; `defstruct''d structure.
+
+(defun struct-closure-p (function)
+ "Is 'function a closure created by defstruct?"
+ (or (function-code-object= function #'kernel::structure-slot-accessor)
+ (function-code-object= function #'kernel::structure-slot-setter)
+ (function-code-object= function #'kernel::%defstruct)))
+
+(defun struct-closure-location (function)
+ "Return the location of the structure that 'function belongs to."
+ (assert (struct-closure-p function))
+ (safe-definition-finding
+ (dd-location (struct-closure-dd function))))
+
+(defun struct-closure-dd (function)
+ "Return the defstruct-definition (dd) of FUNCTION."
+ (assert (= (kernel:get-type function) vm:closure-header-type))
+ (flet ((find-layout (function)
+ (sys:find-if-in-closure
+ (lambda (x)
+ (let ((value (if (di::indirect-value-cell-p x)
+ (c:value-cell-ref x)
+ x)))
+ (when (kernel::layout-p value)
+ (return-from find-layout value))))
+ function)))
+ (kernel:layout-info (find-layout function))))
+
+(defun dd-location (dd)
+ "Return the location of a `defstruct'."
+ ;; Find the location in a constructor.
+ (function-location (struct-constructor dd)))
+
+(defun struct-constructor (dd)
+ "Return a constructor function from a defstruct definition.
+Signal an error if no constructor can be found."
+ (let ((constructor (or (kernel:dd-default-constructor dd)
+ (car (kernel::dd-constructors dd)))))
+ (when (or (null constructor)
+ (and (consp constructor) (null (car constructor))))
+ (error "Cannot find structure's constructor: ~S"
+ (kernel::dd-name dd)))
+ (coerce (if (consp constructor) (first constructor) constructor)
+ 'function)))
+
+;;;;;; Generic functions and methods
+
+(defun generic-function-definitions (name function)
+ "Return the definitions of a generic function and its methods."
+ (cons (list `(defgeneric ,name) (gf-location function))
+ (gf-method-definitions function)))
+
+(defun gf-location (gf)
+ "Return the location of the generic function GF."
+ (definition-source-location gf (clos:generic-function-name gf)))
+
+(defun gf-method-definitions (gf)
+ "Return the locations of all methods of the generic function GF."
+ (mapcar #'method-definition (clos:generic-function-methods gf)))
+
+(defun method-definition (method)
+ (list (method-dspec method)
+ (method-location method)))
+
+(defun method-dspec (method)
+ "Return a human-readable \"definition specifier\" for METHOD."
+ (let* ((gf (clos:method-generic-function method))
+ (name (clos:generic-function-name gf))
+ (specializers (clos:method-specializers method))
+ (qualifiers (clos:method-qualifiers method)))
+ `(method ,name ,@qualifiers ,specializers #+nil (clos::unparse-specializers specializers))))
+
+;; XXX maybe special case setters/getters
+(defun method-location (method)
+ (function-location (clos:method-function method)))
+
+(defun genericp (fn)
+ (typep fn 'generic-function))
+
+;;;;;; Types and classes
+
+(defun type-definitions (name)
+ "Return `deftype' locations for type NAME."
+ (maybe-make-definition (ext:info :type :expander name) 'deftype name))
+
+(defun maybe-make-definition (function kind name)
+ "If FUNCTION is non-nil then return its definition location."
+ (if function
+ (list (list `(,kind ,name) (function-location function)))))
+
+(defun class-definitions (name)
+ "Return the definition locations for the class called NAME."
+ (if (symbolp name)
+ (let ((class (find-class name nil)))
+ (etypecase class
+ (null '())
+ (structure-class
+ (list (list `(defstruct ,name)
+ (dd-location (find-dd name)))))
+ (standard-class
+ (list (list `(defclass ,name)
+ (class-location (find-class name)))))
+ ((or built-in-class
+ kernel:funcallable-structure-class)
+ (list (list `(kernel::define-type-class ,name)
+ `(:error
+ ,(format nil "No source info for ~A" name)))))))))
+
+(defun class-location (class)
+ "Return the `defclass' location for CLASS."
+ (definition-source-location class (class-name class)))
+
+(defun find-dd (name)
+ "Find the defstruct-definition by the name of its structure-class."
+ (let ((layout (ext:info :type :compiler-layout name)))
+ (if layout
+ (kernel:layout-info layout))))
+
+(defun condition-class-location (class)
+ (let ((name (class-name class)))
+ `(:error ,(format nil "No location info for condition: ~A" name))))
+
+(defun make-name-in-file-location (file string)
+ (multiple-value-bind (filename c)
+ (ignore-errors
+ (unix-truename (merge-pathnames (make-pathname :type "lisp")
+ file)))
+ (cond (filename (make-location `(:file ,filename)
+ `(:function-name ,(string string))))
+ (t (list :error (princ-to-string c))))))
+
+(defun definition-source-location (object name)
+ `(:error ,(format nil "No source info for: ~A" object)))
+
+(defun setf-definitions (name)
+ (let ((function (or (ext:info :setf :inverse name)
+ (ext:info :setf :expander name))))
+ (if function
+ (list (list `(setf ,name)
+ (function-location (coerce function 'function)))))))
+
+
+(defun variable-location (symbol)
+ `(:error ,(format nil "No source info for variable ~S" symbol)))
+
+(defun variable-definitions (name)
+ (if (symbolp name)
+ (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
+ (if recorded-p
+ (list (list `(variable ,kind ,name)
+ (variable-location name)))))))
+
+(defun compiler-macro-definitions (symbol)
+ (maybe-make-definition (compiler-macro-function symbol)
+ 'define-compiler-macro
+ symbol))
+
+(defun source-transform-definitions (name)
+ (maybe-make-definition (ext:info :function :source-transform name)
+ 'c:def-source-transform
+ name))
+
+(defun function-info-definitions (name)
+ (let ((info (ext:info :function :info name)))
+ (if info
+ (append (loop for transform in (c::function-info-transforms info)
+ collect (list `(c:deftransform ,name
+ ,(c::type-specifier
+ (c::transform-type transform)))
+ (function-location (c::transform-function
+ transform))))
+ (maybe-make-definition (c::function-info-derive-type info)
+ 'c::derive-type name)
+ (maybe-make-definition (c::function-info-optimizer info)
+ 'c::optimizer name)
+ (maybe-make-definition (c::function-info-ltn-annotate info)
+ 'c::ltn-annotate name)
+ (maybe-make-definition (c::function-info-ir2-convert info)
+ 'c::ir2-convert name)
+ (loop for template in (c::function-info-templates info)
+ collect (list `(c::vop ,(c::template-name template))
+ (function-location
+ (c::vop-info-generator-function
+ template))))))))
+
+(defun ir1-translator-definitions (name)
+ (maybe-make-definition (ext:info :function :ir1-convert name)
+ 'c:def-ir1-translator name))
+
+
+;;;; Documentation.
+
+(defimplementation describe-symbol-for-emacs (symbol)
+ (let ((result '()))
+ (flet ((doc (kind)
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
+ (maybe-push
+ :variable (multiple-value-bind (kind recorded-p)
+ (ext:info variable kind symbol)
+ (declare (ignore kind))
+ (if (or (boundp symbol) recorded-p)
+ (doc 'variable))))
+ (when (fboundp symbol)
+ (maybe-push
+ (cond ((macro-function symbol) :macro)
+ ((special-operator-p symbol) :special-operator)
+ ((genericp (fdefinition symbol)) :generic-function)
+ (t :function))
+ (doc 'function)))
+ (maybe-push
+ :setf (if (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol))
+ (doc 'setf)))
+ (maybe-push
+ :type (if (ext:info type kind symbol)
+ (doc 'type)))
+ (maybe-push
+ :class (if (find-class symbol nil)
+ (doc 'class)))
+ (maybe-push
+ :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
+ (doc 'alien-type)))
+ (maybe-push
+ :alien-struct (if (ext:info alien-type struct symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-union (if (ext:info alien-type union symbol)
+ (doc nil)))
+ (maybe-push
+ :alien-enum (if (ext:info alien-type enum symbol)
+ (doc nil)))
+ result)))
+
+(defimplementation describe-definition (symbol namespace)
+ (describe (ecase namespace
+ (:variable
+ symbol)
+ ((:function :generic-function)
+ (symbol-function symbol))
+ (:setf
+ (or (ext:info setf inverse symbol)
+ (ext:info setf expander symbol)))
+ (:type
+ (kernel:values-specifier-type symbol))
+ (:class
+ (find-class symbol))
+ (:alien-struct
+ (ext:info :alien-type :struct symbol))
+ (:alien-union
+ (ext:info :alien-type :union symbol))
+ (:alien-enum
+ (ext:info :alien-type :enum symbol))
+ (:alien-type
+ (ecase (ext:info :alien-type :kind symbol)
+ (:primitive
+ (let ((alien::*values-type-okay* t))
+ (funcall (ext:info :alien-type :translator symbol)
+ (list symbol))))
+ ((:defined)
+ (ext:info :alien-type :definition symbol))
+ (:unknown :unknown))))))
+
+;;;;; Argument lists
+
+(defimplementation arglist (fun)
+ (etypecase fun
+ (function (function-arglist fun))
+ (symbol (function-arglist (or (macro-function fun)
+ (symbol-function fun))))))
+
+(defun function-arglist (fun)
+ (flet ((compiled-function-arglist (x)
+ (let ((args (kernel:%function-arglist x)))
+ (if args
+ (read-arglist x)
+ :not-available))))
+ (case (kernel:get-type fun)
+ (#.vm:closure-header-type
+ (compiled-function-arglist
+ (kernel:%closure-function fun)))
+ ((#.vm:function-header-type #.vm:closure-function-header-type)
+ (compiled-function-arglist fun))
+ (#.vm:funcallable-instance-header-type
+ (typecase fun
+ (kernel:byte-function
+ :not-available)
+ (kernel:byte-closure
+ :not-available)
+ (eval:interpreted-function
+ (eval:interpreted-function-arglist fun))
+ (otherwise
+ (clos::generic-function-lambda-list fun))))
+ (t
+ :non-available))))
+
+(defimplementation function-name (function)
+ (cond ((eval:interpreted-function-p function)
+ (eval:interpreted-function-name function))
+ ((typep function 'generic-function)
+ (clos:generic-function-name function))
+ ((c::byte-function-or-closure-p function)
+ (c::byte-function-name function))
+ (t (kernel:%function-name (kernel:%function-self function)))))
+
+;;; A simple case: the arglist is available as a string that we can
+;;; `read'.
+
+(defun read-arglist (fn)
+ "Parse the arglist-string of the function object FN."
+ (let ((string (kernel:%function-arglist
+ (kernel:%function-self fn)))
+ (package (find-package
+ (c::compiled-debug-info-package
+ (kernel:%code-debug-info
+ (vm::find-code-object fn))))))
+ (with-standard-io-syntax
+ (let ((*package* (or package *package*)))
+ (read-from-string string)))))
+
+;;; A harder case: an approximate arglist is derived from available
+;;; debugging information.
+
+(defun debug-function-arglist (debug-function)
+ "Derive the argument list of DEBUG-FUNCTION from debug info."
+ (let ((args (di::debug-function-lambda-list debug-function))
+ (required '())
+ (optional '())
+ (rest '())
+ (key '()))
+ ;; collect the names of debug-vars
+ (dolist (arg args)
+ (etypecase arg
+ (di::debug-variable
+ (push (di::debug-variable-symbol arg) required))
+ ((member :deleted)
+ (push ':deleted required))
+ (cons
+ (ecase (car arg)
+ (:keyword
+ (push (second arg) key))
+ (:optional
+ (push (debug-variable-symbol-or-deleted (second arg)) optional))
+ (:rest
+ (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
+ ;; intersperse lambda keywords as needed
+ (append (nreverse required)
+ (if optional (cons '&optional (nreverse optional)))
+ (if rest (cons '&rest (nreverse rest)))
+ (if key (cons '&key (nreverse key))))))
+
+(defun debug-variable-symbol-or-deleted (var)
+ (etypecase var
+ (di:debug-variable
+ (di::debug-variable-symbol var))
+ ((member :deleted)
+ '#:deleted)))
+
+(defun symbol-debug-function-arglist (fname)
+ "Return FNAME's debug-function-arglist and %function-arglist.
+ A utility for debugging DEBUG-FUNCTION-ARGLIST."
+ (let ((fn (fdefinition fname)))
+ (values (debug-function-arglist (di::function-debug-function fn))
+ (kernel:%function-arglist (kernel:%function-self fn)))))
+
+;;; Deriving arglists for byte-compiled functions:
+;;;
+(defun byte-code-function-arglist (fn)
+ ;; There doesn't seem to be much arglist information around for
+ ;; byte-code functions. Use the arg-count and return something like
+ ;; (arg0 arg1 ...)
+ (etypecase fn
+ (c::simple-byte-function
+ (loop for i from 0 below (c::simple-byte-function-num-args fn)
+ collect (make-arg-symbol i)))
+ (c::hairy-byte-function
+ (hairy-byte-function-arglist fn))
+ (c::byte-closure
+ (byte-code-function-arglist (c::byte-closure-function fn)))))
+
+(defun make-arg-symbol (i)
+ (make-symbol (format nil "~A~D" (string 'arg) i)))
+
+;;; A "hairy" byte-function is one that takes a variable number of
+;;; arguments. `hairy-byte-function' is a type from the bytecode
+;;; interpreter.
+;;;
+(defun hairy-byte-function-arglist (fn)
+ (let ((counter -1))
+ (flet ((next-arg () (make-arg-symbol (incf counter))))
+ (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
+ keywords-p keywords) fn
+ (let ((arglist '())
+ (optional (- max-args min-args)))
+ ;; XXX isn't there a better way to write this?
+ ;; (Looks fine to me. -luke)
+ (dotimes (i min-args)
+ (push (next-arg) arglist))
+ (when (plusp optional)
+ (push '&optional arglist)
+ (dotimes (i optional)
+ (push (next-arg) arglist)))
+ (when rest-arg-p
+ (push '&rest arglist)
+ (push (next-arg) arglist))
+ (when keywords-p
+ (push '&key arglist)
+ (loop for (key _ __) in keywords
+ do (push key arglist))
+ (when (eq keywords-p :allow-others)
+ (push '&allow-other-keys arglist)))
+ (nreverse arglist))))))
+
+
+;;;; Miscellaneous.
+
+(defimplementation macroexpand-all (form)
+ (macroexpand form))
+
+(defimplementation set-default-directory (directory)
+ (setf (ext:default-directory) (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+ (default-directory))
+
+(defimplementation default-directory ()
+ (namestring (ext:default-directory)))
+
+(defimplementation call-without-interrupts (fn)
+ (funcall fn))
+
+(defimplementation getpid ()
+ (unix:unix-getpid))
+
+(defimplementation lisp-implementation-type-name ()
+ (if (eq ext:*case-mode* :upper) "scl" "scl-lower"))
+
+(defimplementation quit-lisp ()
+ (ext:quit))
+
+;;; source-path-{stream,file,string,etc}-position moved into
+;;; swank-source-path-parser
+
+
+;;;; Debugging
+
+(defvar *sldb-stack-top*)
+
+(defimplementation call-with-debugging-environment (debugger-loop-fn)
+ (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+ (debug:*stack-top-hint* nil)
+ (kernel:*current-level* 0))
+ (handler-bind ((di::unhandled-condition
+ (lambda (condition)
+ (error (make-condition
+ 'sldb-condition
+ :original-condition condition)))))
+ (funcall debugger-loop-fn))))
+
+(defun frame-down (frame)
+ (handler-case (di:frame-down frame)
+ (di:no-debug-info () nil)))
+
+(defun nth-frame (index)
+ (do ((frame *sldb-stack-top* (frame-down frame))
+ (i index (1- i)))
+ ((zerop i) frame)))
+
+(defimplementation compute-backtrace (start end)
+ (let ((end (or end most-positive-fixnum)))
+ (loop for f = (nth-frame start) then (frame-down f)
+ for i from start below end
+ while f
+ collect f)))
+
+(defimplementation print-frame (frame stream)
+ (let ((*standard-output* stream))
+ (handler-case
+ (debug::print-frame-call frame :verbosity 1 :number nil)
+ (error (e)
+ (ignore-errors (princ e stream))))))
+
+(defimplementation frame-source-location-for-emacs (index)
+ (code-location-source-location (di:frame-code-location (nth-frame index))))
+
+(defimplementation eval-in-frame (form index)
+ (di:eval-in-frame (nth-frame index) form))
+
+(defun frame-debug-vars (frame)
+ "Return a vector of debug-variables in frame."
+ (di::debug-function-debug-variables (di:frame-debug-function frame)))
+
+(defun debug-var-value (var frame location)
+ (let ((validity (di:debug-variable-validity var location)))
+ (ecase validity
+ (:valid (di:debug-variable-value var frame))
+ ((:invalid :unknown) (make-symbol (string validity))))))
+
+(defimplementation frame-locals (index)
+ (let* ((frame (nth-frame index))
+ (loc (di:frame-code-location frame))
+ (vars (frame-debug-vars frame)))
+ (loop for v across vars collect
+ (list :name (di:debug-variable-symbol v)
+ :id (di:debug-variable-id v)
+ :value (debug-var-value v frame loc)))))
+
+(defimplementation frame-var-value (frame var)
+ (let* ((frame (nth-frame frame))
+ (dvar (aref (frame-debug-vars frame) var)))
+ (debug-var-value dvar frame (di:frame-code-location frame))))
+
+(defimplementation frame-catch-tags (index)
+ (mapcar #'car (di:frame-catches (nth-frame index))))
+
+(defimplementation return-from-frame (index form)
+ (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame)
+ :debug-internals)))
+ (if sym
+ (let* ((frame (nth-frame index))
+ (probe (funcall sym frame)))
+ (cond (probe (throw (car probe) (eval-in-frame form index)))
+ (t (format nil "Cannot return from frame: ~S" frame))))
+ "return-from-frame is not implemented in this version of SCL.")))
+
+(defimplementation activate-stepping (frame)
+ (set-step-breakpoints (nth-frame frame)))
+
+(defimplementation sldb-break-on-return (frame)
+ (break-on-return (nth-frame frame)))
+
+;;; We set the breakpoint in the caller which might be a bit confusing.
+;;;
+(defun break-on-return (frame)
+ (let* ((caller (di:frame-down frame))
+ (cl (di:frame-code-location caller)))
+ (flet ((hook (frame bp)
+ (when (frame-pointer= frame caller)
+ (di:delete-breakpoint bp)
+ (signal-breakpoint bp frame))))
+ (let* ((info (ecase (di:code-location-kind cl)
+ ((:single-value-return :unknown-return) nil)
+ (:known-return (debug-function-returns
+ (di:frame-debug-function frame)))))
+ (bp (di:make-breakpoint #'hook cl :kind :code-location
+ :info info)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
+
+(defun frame-pointer= (frame1 frame2)
+ "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
+ (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
+
+;;; The PC in escaped frames at a single-return-value point is
+;;; actually vm:single-value-return-byte-offset bytes after the
+;;; position given in the debug info. Here we try to recognize such
+;;; cases.
+;;;
+(defun next-code-locations (frame code-location)
+ "Like `debug::next-code-locations' but be careful in escaped frames."
+ (let ((next (debug::next-code-locations code-location)))
+ (flet ((adjust-pc ()
+ (let ((cl (di::copy-compiled-code-location code-location)))
+ (incf (di::compiled-code-location-pc cl)
+ vm:single-value-return-byte-offset)
+ cl)))
+ (cond ((and (di::compiled-frame-escaped frame)
+ (eq (di:code-location-kind code-location)
+ :single-value-return)
+ (= (length next) 1)
+ (di:code-location= (car next) (adjust-pc)))
+ (debug::next-code-locations (car next)))
+ (t
+ next)))))
+
+(defun set-step-breakpoints (frame)
+ (let ((cl (di:frame-code-location frame)))
+ (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
+ (error "Cannot step in elsewhere code"))
+ (let* ((debug::*bad-code-location-types*
+ (remove :call-site debug::*bad-code-location-types*))
+ (next (next-code-locations frame cl)))
+ (cond (next
+ (let ((steppoints '()))
+ (flet ((hook (bp-frame bp)
+ (signal-breakpoint bp bp-frame)
+ (mapc #'di:delete-breakpoint steppoints)))
+ (dolist (code-location next)
+ (let ((bp (di:make-breakpoint #'hook code-location
+ :kind :code-location)))
+ (di:activate-breakpoint bp)
+ (push bp steppoints))))))
+ (t
+ (break-on-return frame))))))
+
+
+;; XXX the return values at return breakpoints should be passed to the
+;; user hooks. debug-int.lisp should be changed to do this cleanly.
+
+;;; The sigcontext and the PC for a breakpoint invocation are not
+;;; passed to user hook functions, but we need them to extract return
+;;; values. So we advice di::handle-breakpoint and bind the values to
+;;; special variables.
+;;;
+(defvar *breakpoint-sigcontext*)
+(defvar *breakpoint-pc*)
+
+(defun sigcontext-object (sc index)
+ "Extract the lisp object in sigcontext SC at offset INDEX."
+ (kernel:make-lisp-obj (vm:ucontext-register sc index)))
+
+(defun known-return-point-values (sigcontext sc-offsets)
+ (let ((fp (system:int-sap (vm:ucontext-register sigcontext
+ vm::cfp-offset))))
+ (system:without-gcing
+ (loop for sc-offset across sc-offsets
+ collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
+
+;;; SCL returns the first few values in registers and the rest on
+;;; the stack. In the multiple value case, the number of values is
+;;; stored in a dedicated register. The values of the registers can be
+;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
+;;; of return conventions: :single-value-return, :unknown-return, and
+;;; :known-return.
+;;;
+;;; The :single-value-return convention returns the value in a
+;;; register without setting the nargs registers.
+;;;
+;;; The :unknown-return variant is used for multiple values. A
+;;; :unknown-return point consists actually of 2 breakpoints: one for
+;;; the single value case and one for the general case. The single
+;;; value breakpoint comes vm:single-value-return-byte-offset after
+;;; the multiple value breakpoint.
+;;;
+;;; The :known-return convention is used by local functions.
+;;; :known-return is currently not supported because we don't know
+;;; where the values are passed.
+;;;
+(defun breakpoint-values (breakpoint)
+ "Return the list of return values for a return point."
+ (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
+ (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
+ (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext))))
+ (cl (di:breakpoint-what breakpoint)))
+ (ecase (di:code-location-kind cl)
+ (:single-value-return
+ (list (1st sc)))
+ (:known-return
+ (let ((info (di:breakpoint-info breakpoint)))
+ (if (vectorp info)
+ (known-return-point-values sc info)
+ (progn
+ ;;(break)
+ (list "<<known-return convention not supported>>" info)))))
+ (:unknown-return
+ (let ((mv-return-pc (di::compiled-code-location-pc cl)))
+ (if (= mv-return-pc *breakpoint-pc*)
+ (mv-function-end-breakpoint-values sc)
+ (list (1st sc)))))))))
+
+(defun mv-function-end-breakpoint-values (sigcontext)
+ (let ((sym (find-symbol (symbol-name '#:function-end-breakpoint-values/standard)
+ :debug-internals)))
+ (cond (sym (funcall sym sigcontext))
+ (t (di::get-function-end-breakpoint-values sigcontext)))))
+
+(defun debug-function-returns (debug-fun)
+ "Return the return style of DEBUG-FUN."
+ (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
+ (c::compiled-debug-function-returns cdfun)))
+
+(define-condition breakpoint (simple-condition)
+ ((message :initarg :message :reader breakpoint.message)
+ (values :initarg :values :reader breakpoint.values))
+ (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+
+#+nil
+(defimplementation condition-extras ((c breakpoint))
+ ;; simply pop up the source buffer
+ `((:short-frame-source 0)))
+
+(defun signal-breakpoint (breakpoint frame)
+ "Signal a breakpoint condition for BREAKPOINT in FRAME.
+Try to create a informative message."
+ (flet ((brk (values fstring &rest args)
+ (let ((msg (apply #'format nil fstring args))
+ (debug:*stack-top-hint* frame))
+ (break 'breakpoint :message msg :values values))))
+ (with-struct (di::breakpoint- kind what) breakpoint
+ (case kind
+ (:code-location
+ (case (di:code-location-kind what)
+ ((:single-value-return :known-return :unknown-return)
+ (let ((values (breakpoint-values breakpoint)))
+ (brk values "Return value: ~{~S ~}" values)))
+ (t
+ #+(or)
+ (when (eq (di:code-location-kind what) :call-site)
+ (call-site-function breakpoint frame))
+ (brk nil "Breakpoint: ~S ~S"
+ (di:code-location-kind what)
+ (di::compiled-code-location-pc what)))))
+ (:function-start
+ (brk nil "Function start breakpoint"))
+ (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
+
+#+nil
+(defimplementation sldb-break-at-start (fname)
+ (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
+ (cond ((not debug-fun)
+ `(:error ,(format nil "~S has no debug-function" fname)))
+ (t
+ (flet ((hook (frame bp &optional args cookie)
+ (declare (ignore args cookie))
+ (signal-breakpoint bp frame)))
+ (let ((bp (di:make-breakpoint #'hook debug-fun
+ :kind :function-start)))
+ (di:activate-breakpoint bp)
+ `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
+
+(defun frame-cfp (frame)
+ "Return the Control-Stack-Frame-Pointer for FRAME."
+ (etypecase frame
+ (di::compiled-frame (di::frame-pointer frame))
+ ((or di::interpreted-frame null) -1)))
+
+(defun frame-ip (frame)
+ "Return the (absolute) instruction pointer and the relative pc of FRAME."
+ (if (not frame)
+ -1
+ (let ((debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((code-loc (di:frame-code-location frame))
+ (component (di::compiled-debug-function-component debug-fun))
+ (pc (di::compiled-code-location-pc code-loc))
+ (ip (sys:without-gcing
+ (sys:sap-int
+ (sys:sap+ (kernel:code-instructions component) pc)))))
+ (values ip pc)))
+ ((or di::bogus-debug-function di::interpreted-debug-function)
+ -1)))))
+
+(defun frame-registers (frame)
+ "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
+ (let* ((cfp (frame-cfp frame))
+ (csp (frame-cfp (di::frame-up frame)))
+ (ip (frame-ip frame))
+ (ocfp (frame-cfp (di::frame-down frame)))
+ (lra (frame-ip (di::frame-down frame))))
+ (values csp cfp ip ocfp lra)))
+
+(defun print-frame-registers (frame-number)
+ (let ((frame (di::frame-real-frame (nth-frame frame-number))))
+ (flet ((fixnum (p) (etypecase p
+ (integer p)
+ (sys:system-area-pointer (sys:sap-int p)))))
+ (apply #'format t "~
+CSP = ~X
+CFP = ~X
+IP = ~X
+OCFP = ~X
+LRA = ~X~%" (mapcar #'fixnum
+ (multiple-value-list (frame-registers frame)))))))
+
+
+(defimplementation disassemble-frame (frame-number)
+ "Return a string with the disassembly of frames code."
+ (print-frame-registers frame-number)
+ (terpri)
+ (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
+ (debug-fun (di::frame-debug-function frame)))
+ (etypecase debug-fun
+ (di::compiled-debug-function
+ (let* ((component (di::compiled-debug-function-component debug-fun))
+ (fun (di:debug-function-function debug-fun)))
+ (if fun
+ (disassemble fun)
+ (disassem:disassemble-code-component component))))
+ (di::bogus-debug-function
+ (format t "~%[Disassembling bogus frames not implemented]")))))
+
+
+;;;; Inspecting
+
+(defclass scl-inspector (backend-inspector) ())
+
+(defimplementation make-default-inspector ()
+ (make-instance 'scl-inspector))
+
+(defconstant +lowtag-symbols+
+ '(vm:even-fixnum-type
+ vm:instance-pointer-type
+ vm:other-immediate-0-type
+ vm:list-pointer-type
+ vm:odd-fixnum-type
+ vm:function-pointer-type
+ vm:other-immediate-1-type
+ vm:other-pointer-type)
+ "Names of the constants that specify type tags.
+The `symbol-value' of each element is a type tag.")
+
+(defconstant +header-type-symbols+
+ (labels ((suffixp (suffix string)
+ (and (>= (length string) (length suffix))
+ (string= string suffix :start1 (- (length string)
+ (length suffix)))))
+ (header-type-symbol-p (x)
+ (and (suffixp (symbol-name '#:-type) (symbol-name x))
+ (not (member x +lowtag-symbols+))
+ (boundp x)
+ (typep (symbol-value x) 'fixnum))))
+ (remove-if-not #'header-type-symbol-p
+ (append (apropos-list (symbol-name '#:-type) :vm)
+ (apropos-list (symbol-name '#:-type) :bignum))))
+ "A list of names of the type codes in boxed objects.")
+
+(defimplementation 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)))
+ (format t "lowtag: ~A" lowtag-symbol)
+ (when (member lowtag (list vm:other-pointer-type
+ vm:function-pointer-type
+ vm:other-immediate-0-type
+ vm:other-immediate-1-type
+ ))
+ (let* ((type (kernel:get-type object))
+ (type-symbol (find type +header-type-symbols+
+ :key #'symbol-value)))
+ (format t ", type: ~A" type-symbol))))))
+
+(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+ (cond ((di::indirect-value-cell-p o)
+ (values (format nil "~A is a value cell." o)
+ `("Value: " (:value ,(c:value-cell-ref o)))))
+ ((alien::alien-value-p o)
+ (inspect-alien-value o))
+ (t
+ (scl-inspect o))))
+
+(defun scl-inspect (o)
+ (destructuring-bind (text labeledp . parts)
+ (inspect::describe-parts o)
+ (values (format nil "~A~%" text)
+ (if labeledp
+ (loop for (label . value) in parts
+ append (label-value-line label value))
+ (loop for value in parts for i from 0
+ append (label-value-line i value))))))
+
+(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (let ((header (kernel:get-type o)))
+ (cond ((= header vm:function-header-type)
+ (values (format nil "~A is a function." o)
+ (append (label-value-line*
+ ("Self" (kernel:%function-self o))
+ ("Next" (kernel:%function-next o))
+ ("Name" (kernel:%function-name o))
+ ("Arglist" (kernel:%function-arglist o))
+ ("Type" (kernel:%function-type o))
+ ("Code" (kernel:function-code-header o)))
+ (list
+ (with-output-to-string (s)
+ (disassem:disassemble-function o :stream s))))))
+ ((= header vm:closure-header-type)
+ (values (format nil "~A is a closure" o)
+ (append
+ (label-value-line "Function" (kernel:%closure-function o))
+ `("Environment:" (:newline))
+ (loop for i from 0 below (- (kernel:get-closure-length o)
+ (1- vm:closure-info-offset))
+ append (label-value-line
+ i (kernel:%closure-index-ref o i))))))
+ ((eval::interpreted-function-p o)
+ (scl-inspect o))
+ (t
+ (call-next-method)))))
+
+
+(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector))
+ (declare (ignore _))
+ (values (format nil "~A is a code data-block." o)
+ (append
+ (label-value-line*
+ ("code-size" (kernel:%code-code-size o))
+ ("entry-points" (kernel:%code-entry-points o))
+ ("debug-info" (kernel:%code-debug-info o))
+ ("trace-table-offset" (kernel:code-header-ref
+ o vm:code-trace-table-offset-slot)))
+ `("Constants:" (:newline))
+ (loop for i from vm:code-constants-offset
+ below (kernel:get-header-data o)
+ append (label-value-line i (kernel:code-header-ref o i)))
+ `("Code:" (:newline)
+ , (with-output-to-string (s)
+ (cond ((kernel:%code-debug-info o)
+ (disassem:disassemble-code-component o :stream s))
+ (t
+ (disassem:disassemble-memory
+ (disassem::align
+ (+ (logandc2 (kernel:get-lisp-obj-address o)
+ vm:lowtag-mask)
+ (* vm:code-constants-offset vm:word-bytes))
+ (ash 1 vm:lowtag-bits))
+ (ash (kernel:%code-code-size o) vm:word-shift)
+ :stream s))))))))
+
+(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector))
+ (declare (ignore inspector))
+ (values (format nil "~A is a fdenf object." o)
+ (label-value-line*
+ ("name" (kernel:fdefn-name o))
+ ("function" (kernel:fdefn-function o))
+ ("raw-addr" (sys:sap-ref-32
+ (sys:int-sap (kernel:get-lisp-obj-address o))
+ (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
+
+(defmethod inspect-for-emacs ((o array) (inspector backend-inspector))
+ inspector
+ (cond ((kernel:array-header-p o)
+ (values (format nil "~A is an array." o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:rank (array-rank o))
+ (:fill-pointer (kernel:%array-fill-pointer o))
+ (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+ (:elements (kernel:%array-available-elements o))
+ (:data (kernel:%array-data-vector o))
+ (:displacement (kernel:%array-displacement o))
+ (:displaced-p (kernel:%array-displaced-p o))
+ (:dimensions (array-dimensions o)))))
+ (t
+ (values (format nil "~A is an simple-array." o)
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (length o)))))))
+
+(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector))
+ inspector
+ (values (format nil "~A is a vector." o)
+ (append
+ (label-value-line*
+ (:header (describe-primitive-type o))
+ (:length (c::vector-length o)))
+ (unless (eq (array-element-type o) 'nil)
+ (loop for i below (length o)
+ append (label-value-line i (aref o i)))))))
+
+(defun inspect-alien-record (alien)
+ (values
+ (format nil "~A is an alien value." alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (with-struct (alien::alien-record-type- kind name fields) type
+ (append
+ (label-value-line*
+ (:sap sap)
+ (:kind kind)
+ (:name name))
+ (loop for field in fields
+ append (let ((slot (alien::alien-record-field-name field)))
+ (label-value-line slot (alien:slot alien slot)))))))))
+
+(defun inspect-alien-pointer (alien)
+ (values
+ (format nil "~A is an alien value." alien)
+ (with-struct (alien::alien-value- sap type) alien
+ (label-value-line*
+ (:sap sap)
+ (:type type)
+ (:to (alien::deref alien))))))
+
+(defun inspect-alien-value (alien)
+ (typecase (alien::alien-value-type alien)
+ (alien::alien-record-type (inspect-alien-record alien))
+ (alien::alien-pointer-type (inspect-alien-pointer alien))
+ (t (scl-inspect alien))))
+
+;;;; Profiling
+(defimplementation profile (fname)
+ (eval `(profile:profile ,fname)))
+
+(defimplementation unprofile (fname)
+ (eval `(profile:unprofile ,fname)))
+
+(defimplementation unprofile-all ()
+ (eval `(profile:unprofile))
+ "All functions unprofiled.")
+
+(defimplementation profile-report ()
+ (eval `(profile:report-time)))
+
+(defimplementation profile-reset ()
+ (eval `(profile:reset-time))
+ "Reset profiling counters.")
+
+(defimplementation profiled-functions ()
+ profile:*timed-functions*)
+
+(defimplementation profile-package (package callers methods)
+ (profile:profile-all :package package
+ :callers-p callers
+ #+nil :methods #+nil methods))
+
+
+;;;; Multiprocessing
+
+(defimplementation spawn (fn &key name)
+ (thread:thread-create fn :name (or name "Anonymous")))
+
+(defvar *thread-id-counter* 0)
+(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter"))
+
+(defimplementation thread-id (thread)
+ (thread:with-lock-held (*thread-id-counter-lock*)
+ (or (getf (thread:thread-plist thread) 'id)
+ (setf (getf (thread:thread-plist thread) 'id)
+ (incf *thread-id-counter*)))))
+
+(defimplementation find-thread (id)
+ (block find-thread
+ (thread:map-over-threads
+ #'(lambda (thread)
+ (when (eql (getf (thread:thread-plist thread) 'id) id)
+ (return-from find-thread thread))))))
+
+(defimplementation thread-name (thread)
+ (princ-to-string (thread:thread-name thread)))
+
+(defimplementation thread-status (thread)
+ (let ((dynamic-values (thread::thread-dynamic-values thread)))
+ (if (zerop dynamic-values) "Exited" "Running")))
+
+(defimplementation make-lock (&key name)
+ (thread:make-lock name))
+
+(defimplementation call-with-lock-held (lock function)
+ (declare (type function function))
+ (thread:with-lock-held (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ thread:*thread*)
+
+(defimplementation all-threads ()
+ (let ((all-threads nil))
+ (thread:map-over-threads #'(lambda (thread) (push thread all-threads)))
+ all-threads))
+
+(defimplementation interrupt-thread (thread fn)
+ (thread:thread-interrupt thread #'(lambda ()
+ (sys:with-interrupts
+ (funcall fn)))))
+
+(defimplementation kill-thread (thread)
+ (thread:destroy-thread thread))
+
+(defimplementation thread-alive-p (thread)
+ (not (zerop (thread::thread-dynamic-values thread))))
+
+(defvar *mailbox-lock* (thread:make-lock "Mailbox lock"))
+
+(defstruct (mailbox)
+ (lock (thread:make-lock "Thread mailbox" :type :error-check
+ :interruptible nil)
+ :type thread:error-check-lock)
+ (queue '() :type list))
+
+(defun mailbox (thread)
+ "Return 'thread's mailbox."
+ (thread:with-lock-held (*mailbox-lock*)
+ (or (getf (thread:thread-plist thread) 'mailbox)
+ (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (let* ((mbox (mailbox thread))
+ (lock (mailbox-lock mbox)))
+ (sys:without-interrupts
+ (thread:with-lock-held (lock "Mailbox Send")
+ (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+ (list message)))))
+ (mp:process-wakeup thread)
+ message))
+
+(defimplementation receive ()
+ (let* ((mbox (mailbox thread:*thread*))
+ (lock (mailbox-lock mbox)))
+ (loop
+ (mp:process-wait-with-timeout "Mailbox read wait" 1
+ #'(lambda () (mailbox-queue mbox)))
+ (multiple-value-bind (message winp)
+ (sys:without-interrupts
+ (mp:with-lock-held (lock "Mailbox read")
+ (let ((queue (mailbox-queue mbox)))
+ (cond (queue
+ (setf (mailbox-queue mbox) (cdr queue))
+ (values (car queue) t))
+ (t
+ (values nil nil))))))
+ (when winp
+ (return message))))))
+
+
+
+(defimplementation emacs-connected ())
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;Trace implementations
+;; In SCL, we have:
+;; (trace <name>)
+;; (trace (method <name> <qualifier>? (<specializer>+)))
+;; (trace :methods t '<name>) ;;to trace all methods of the gf <name>
+;; <name> can be a normal name or a (setf name)
+
+(defun tracedp (spec)
+ (member spec (eval '(trace)) :test #'equal))
+
+(defun toggle-trace-aux (spec &rest options)
+ (cond ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec ,@options))
+ (format nil "~S is now traced." spec))))
+
+(defimplementation toggle-trace (spec)
+ (ecase (car spec)
+ ((setf)
+ (toggle-trace-aux spec))
+ ((:defgeneric)
+ (let ((name (second spec)))
+ (toggle-trace-aux name :methods name)))
+ ((:defmethod)
+ nil)
+ ((:call)
+ (destructuring-bind (caller callee) (cdr spec)
+ (toggle-trace-aux (process-fspec callee)
+ :wherein (list (process-fspec caller)))))))
+
+(defun process-fspec (fspec)
+ (cond ((consp fspec)
+ (ecase (first fspec)
+ ((:defun :defgeneric) (second fspec))
+ ((:defmethod)
+ `(method ,(second fspec) ,@(third fspec) ,(fourth fspec)))
+ ;; this isn't actually supported
+ ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
+ ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
+ (t
+ fspec)))
+
+;;; Weak datastructures
+
+;;; Not implemented in SCL.
+(defimplementation make-weak-key-hash-table (&rest args)
+ (apply #'make-hash-table :weak-p t args))
+
+;; Local Variables:
+;; pbook-heading-regexp: "^;;;\\(;+\\)"
+;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
+;; End:
Added: branches/bos/thirdparty/emacs/slime/swank-source-file-cache.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-source-file-cache.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,118 @@
+;;;; Source-file cache
+;;;
+;;; To robustly find source locations in CMUCL and SBCL it's useful to
+;;; have the exact source code that the loaded code was compiled from.
+;;; In this source we can accurately find the right location, and from
+;;; that location we can extract a "snippet" of code to show what the
+;;; definition looks like. Emacs can use this snippet in a best-match
+;;; search to locate the right definition, which works well even if
+;;; the buffer has been modified.
+;;;
+;;; The idea is that if a definition previously started with
+;;; `(define-foo bar' then it probably still does.
+;;;
+;;; Whenever we see that the file on disk has the same
+;;; `file-write-date' as a location we're looking for we cache the
+;;; whole file inside Lisp. That way we will still have the matching
+;;; version even if the file is later modified on disk. If the file is
+;;; later recompiled and reloaded then we replace our cache entry.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+(in-package :swank-backend)
+
+(defvar *cache-sourcecode* t
+ "When true complete source files are cached.
+The cache is used to keep known good copies of the source text which
+correspond to the loaded code. Finding definitions is much more
+reliable when the exact source is available, so we cache it in case it
+gets edited on disk later.")
+
+(defvar *source-file-cache* (make-hash-table :test 'equal)
+ "Cache of source file contents.
+Maps from truename to source-cache-entry structure.")
+
+(defstruct (source-cache-entry
+ (:conc-name source-cache-entry.)
+ (:constructor make-source-cache-entry (text date)))
+ text date)
+
+(defimplementation buffer-first-change (filename)
+ "Load a file into the cache when the user modifies its buffer.
+This is a win if the user then saves the file and tries to M-. into it."
+ (unless (source-cached-p filename)
+ (ignore-errors
+ (source-cache-get filename (file-write-date filename))))
+ nil)
+
+(defun get-source-code (filename code-date)
+ "Return the source code for FILENAME as written on DATE in a string.
+If the exact version cannot be found then return the current one from disk."
+ (or (source-cache-get filename code-date)
+ (read-file filename)))
+
+(defun source-cache-get (filename date)
+ "Return the source code for FILENAME as written on DATE in a string.
+Return NIL if the right version cannot be found."
+ (when *cache-sourcecode*
+ (let ((entry (gethash filename *source-file-cache*)))
+ (cond ((and entry (equal date (source-cache-entry.date entry)))
+ ;; Cache hit.
+ (source-cache-entry.text entry))
+ ((or (null entry)
+ (not (equal date (source-cache-entry.date entry))))
+ ;; Cache miss.
+ (if (equal (file-write-date filename) date)
+ ;; File on disk has the correct version.
+ (let ((source (read-file filename)))
+ (setf (gethash filename *source-file-cache*)
+ (make-source-cache-entry source date))
+ source)
+ nil))))))
+
+(defun source-cached-p (filename)
+ "Is any version of FILENAME in the source cache?"
+ (if (gethash filename *source-file-cache*) t))
+
+(defun read-file (filename)
+ "Return the entire contents of FILENAME as a string."
+ (with-open-file (s filename :direction :input
+ :external-format (or (guess-external-format filename)
+ (find-external-format "latin-1")
+ :default))
+ (let ((string (make-string (file-length s))))
+ (read-sequence string s)
+ string)))
+
+;;;; Snippets
+
+(defvar *source-snippet-size* 256
+ "Maximum number of characters in a snippet of source code.
+Snippets at the beginning of definitions are used to tell Emacs what
+the definitions looks like, so that it can accurately find them by
+text search.")
+
+(defun read-snippet (stream &optional position)
+ "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM.
+If POSITION is given, set the STREAM's file position first."
+ (when position
+ (file-position stream position))
+ #+SBCL (skip-comments-and-whitespace stream)
+ (read-upto-n-chars stream *source-snippet-size*))
+
+(defun skip-comments-and-whitespace (stream)
+ (case (peek-char nil stream)
+ ((#\Space #\Tab #\Newline #\Linefeed)
+ (read-char stream)
+ (skip-comments-and-whitespace stream))
+ (#\;
+ (read-line stream)
+ (skip-comments-and-whitespace stream))))
+
+(defun read-upto-n-chars (stream n)
+ "Return a string of upto N chars from STREAM."
+ (let* ((string (make-string n))
+ (chars (read-sequence string stream)))
+ (subseq string 0 chars)))
+
Added: branches/bos/thirdparty/emacs/slime/swank-source-path-parser.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank-source-path-parser.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,131 @@
+;;;; Source-paths
+
+;;; CMUCL/SBCL use a data structure called "source-path" to locate
+;;; subforms. The compiler assigns a source-path to each form in a
+;;; compilation unit. Compiler notes usually contain the source-path
+;;; of the error location.
+;;;
+;;; Compiled code objects don't contain source paths, only the
+;;; "toplevel-form-number" and the (sub-) "form-number". To get from
+;;; the form-number to the source-path we need the entire toplevel-form
+;;; (i.e. we have to read the source code). CMUCL has already some
+;;; utilities to do this translation, but we use some extended
+;;; versions, because we need more exact position info. Apparently
+;;; Hemlock is happy with the position of the toplevel-form; we also
+;;; need the position of subforms.
+;;;
+;;; We use a special readtable to get the positions of the subforms.
+;;; The readtable stores the start and end position for each subform in
+;;; hashtable for later retrieval.
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+
+;;; Taken from swank-cmucl.lisp, by Helmut Eller
+
+(in-package :swank-backend)
+
+;; Some test to ensure the required conformance
+(let ((rt (copy-readtable nil)))
+ (assert (or (not (get-macro-character #\space rt))
+ (nth-value 1 (get-macro-character #\space rt))))
+ (assert (not (get-macro-character #\\ rt))))
+
+(defun make-source-recorder (fn source-map)
+ "Return a macro character function that does the same as FN, but
+additionally stores the result together with the stream positions
+before and after of calling FN in the hashtable SOURCE-MAP."
+ (declare (type function fn))
+ (lambda (stream char)
+ (let ((start (file-position stream))
+ (values (multiple-value-list (funcall fn stream char)))
+ (end (file-position stream)))
+ ;;(format t "[~D ~{~A~^, ~} ~D ~D]~%" start values end (char-code char))
+ (unless (null values)
+ (push (cons start end) (gethash (car values) source-map)))
+ (values-list values))))
+
+(defun make-source-recording-readtable (readtable source-map)
+ "Return a source position recording copy of READTABLE.
+The source locations are stored in SOURCE-MAP."
+ (let* ((tab (copy-readtable readtable))
+ (*readtable* tab))
+ (dotimes (code 128)
+ (let ((char (code-char code)))
+ (multiple-value-bind (fn term) (get-macro-character char tab)
+ (when fn
+ (set-macro-character char (make-source-recorder fn source-map)
+ term tab)))))
+ (suppress-sharp-dot tab)
+ tab))
+
+(defun suppress-sharp-dot (readtable)
+ (when (get-macro-character #\# readtable)
+ (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable)))
+ (set-dispatch-macro-character #\# #\. (lambda (&rest args)
+ (let ((*read-suppress* t))
+ (apply sharp-dot args))
+ (if *read-suppress*
+ (values)
+ (list (gensym "#."))))
+ readtable))))
+
+(defun read-and-record-source-map (stream)
+ "Read the next object from STREAM.
+Return the object together with a hashtable that maps
+subexpressions of the object to stream positions."
+ (let* ((source-map (make-hash-table :test #'eq))
+ (*readtable* (make-source-recording-readtable *readtable* source-map))
+ (start (file-position stream))
+ (form (read stream))
+ (end (file-position stream)))
+ ;; ensure that at least FORM is in the source-map
+ (unless (gethash form source-map)
+ (push (cons start end) (gethash form source-map)))
+ (values form source-map)))
+
+(defun read-source-form (n stream)
+ "Read the Nth toplevel form number with source location recording.
+Return the form and the source-map."
+ (let ((*read-suppress* t))
+ (dotimes (i n)
+ (read stream)))
+ (let ((*read-suppress* nil)
+ (*read-eval* nil))
+ (read-and-record-source-map stream)))
+
+(defun source-path-stream-position (path stream)
+ "Search the source-path PATH in STREAM and return its position."
+ (check-source-path path)
+ (destructuring-bind (tlf-number . path) path
+ (multiple-value-bind (form source-map) (read-source-form tlf-number stream)
+ (source-path-source-position (cons 0 path) form source-map))))
+
+(defun check-source-path (path)
+ (unless (and (consp path)
+ (every #'integerp path))
+ (error "The source-path ~S is not valid." path)))
+
+(defun source-path-string-position (path string)
+ (with-input-from-string (s string)
+ (source-path-stream-position path s)))
+
+(defun source-path-file-position (path filename)
+ (with-open-file (file filename)
+ (source-path-stream-position path file)))
+
+(defun source-path-source-position (path form source-map)
+ "Return the start position of PATH from FORM and SOURCE-MAP. All
+subforms along the path are considered and the start and end position
+of the deepest (i.e. smallest) possible form is returned."
+ ;; compute all subforms along path
+ (let ((forms (loop for n in path
+ for f = form then (nth n f)
+ collect f)))
+ ;; select the first subform present in source-map
+ (loop for form in (reverse forms)
+ for positions = (gethash form source-map)
+ until (and positions (null (cdr positions)))
+ finally (destructuring-bind ((start . end)) positions
+ (return (values (1- start) end))))))
+
Added: branches/bos/thirdparty/emacs/slime/swank.asd
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank.asd Fri Jan 18 06:05:59 2008
@@ -0,0 +1,48 @@
+;;; -*- lisp -*-
+
+;; ASDF system definition for loading the Swank server independently
+;; of Emacs.
+;;
+;; This is only useful if you want to start a Swank server in a Lisp
+;; processes that doesn't run under Emacs. Lisp processes created by
+;; `M-x slime' automatically start the server.
+
+;; Usage:
+;;
+;; (require :swank)
+;; (swank:create-swank-server PORT) => ACTUAL-PORT
+;;
+;; (PORT can be zero to mean "any available port".)
+;; Then the Swank server is running on localhost:ACTUAL-PORT. You can
+;; use `M-x slime-connect' to connect Emacs to it.
+;;
+;; This code has been placed in the Public Domain. All warranties
+;; are disclaimed.
+
+(defpackage :swank-loader
+ (:use :cl))
+
+(in-package :swank-loader)
+
+(defclass cl-script-file (asdf:source-file) ())
+
+(defmethod asdf:perform ((o asdf:compile-op) (f cl-script-file))
+ t)
+(defmethod asdf:perform ((o asdf:load-op) (f cl-script-file))
+ (mapcar #'load (asdf:input-files o f)))
+(defmethod asdf:output-files ((o asdf:compile-op) (f cl-script-file))
+ nil)
+(defmethod asdf:input-files ((o asdf:load-op) (c cl-script-file))
+ (list (asdf:component-pathname c)))
+(defmethod asdf:operation-done-p ((o asdf:compile-op) (c cl-script-file))
+ t)
+(defmethod asdf:source-file-type ((c cl-script-file) (s asdf:module))
+ "lisp")
+
+(asdf:defsystem :swank
+ :default-component-class cl-script-file
+ :components ((:file "swank-loader")))
+
+(defparameter *source-directory*
+ (asdf:component-pathname (asdf:find-system :swank)))
+
Added: branches/bos/thirdparty/emacs/slime/swank.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/swank.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,3262 @@
+;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
+;;;
+;;; This code has been placed in the Public Domain. All warranties
+;;; are disclaimed.
+;;;
+;;;; swank.lisp
+;;;
+;;; This file defines the "Swank" TCP server for Emacs to talk to. The
+;;; code in this file is purely portable Common Lisp. We do require a
+;;; smattering of non-portable functions in order to write the server,
+;;; so we have defined them in `swank-backend.lisp' and implemented
+;;; them separately for each Lisp implementation. These extensions are
+;;; available to us here via the `SWANK-BACKEND' package.
+
+(defpackage :swank
+ (:use :common-lisp :swank-backend)
+ (:export #:startup-multiprocessing
+ #:start-server
+ #:create-server
+ #:stop-server
+ #:restart-server
+ #:ed-in-emacs
+ #:inspect-in-emacs
+ #:print-indentation-lossage
+ #:swank-debugger-hook
+ #:run-after-init-hook
+ #:inspect-for-emacs
+ #:inspect-slot-for-emacs
+ ;; These are user-configurable variables:
+ #:*communication-style*
+ #:*dont-close*
+ #:*log-events*
+ #:*log-output*
+ #:*use-dedicated-output-stream*
+ #:*dedicated-output-stream-port*
+ #:*configure-emacs-indentation*
+ #:*readtable-alist*
+ #:*globally-redirect-io*
+ #:*global-debugger*
+ #:*sldb-printer-bindings*
+ #:*swank-pprint-bindings*
+ #:*default-worker-thread-bindings*
+ #:*macroexpand-printer-bindings*
+ #:*record-repl-results*
+ #:*debug-on-swank-error*
+ ;; These are re-exported directly from the backend:
+ #:buffer-first-change
+ #:frame-source-location-for-emacs
+ #:restart-frame
+ #:sldb-step
+ #:sldb-break
+ #:sldb-break-on-return
+ #:profiled-functions
+ #:profile-report
+ #:profile-reset
+ #:unprofile-all
+ #:profile-package
+ #:default-directory
+ #:set-default-directory
+ #:quit-lisp))
+
+(in-package :swank)
+
+
+;;;; Top-level variables, constants, macros
+
+(defconstant cl-package (find-package :cl)
+ "The COMMON-LISP package.")
+
+(defconstant keyword-package (find-package :keyword)
+ "The KEYWORD package.")
+
+(defvar *canonical-package-nicknames*
+ `((:common-lisp-user . :cl-user))
+ "Canonical package names to use instead of shortest name/nickname.")
+
+(defvar *auto-abbreviate-dotted-packages* t
+ "Abbreviate dotted package names to their last component if T.")
+
+(defvar *swank-io-package*
+ (let ((package (make-package :swank-io-package :use '())))
+ (import '(nil t quote) package)
+ package))
+
+(defconstant default-server-port 4005
+ "The default TCP port for the server (when started manually).")
+
+(defvar *swank-debug-p* t
+ "When true, print extra debugging information.")
+
+(defvar *redirect-io* t
+ "When non-nil redirect Lisp standard I/O to Emacs.
+Redirection is done while Lisp is processing a request for Emacs.")
+
+(defvar *sldb-printer-bindings*
+ `((*print-pretty* . t)
+ (*print-level* . 4)
+ (*print-length* . 10)
+ (*print-circle* . t)
+ (*print-readably* . nil)
+ (*print-pprint-dispatch* . ,(copy-pprint-dispatch nil))
+ (*print-gensym* . t)
+ (*print-base* . 10)
+ (*print-radix* . nil)
+ (*print-array* . t)
+ (*print-lines* . 10)
+ (*print-escape* . t)
+ (*print-right-margin* . 65))
+ "A set of printer variables used in the debugger.")
+
+(defvar *backtrace-printer-bindings*
+ `((*print-pretty* . nil)
+ (*print-level* . 4)
+ (*print-length* . 6))
+ "Pretter settings for printing backtraces.")
+
+(defvar *default-worker-thread-bindings* '()
+ "An alist to initialize dynamic variables in worker threads.
+The list has the form ((VAR . VALUE) ...). Each variable VAR will be
+bound to the corresponding VALUE.")
+
+(defun call-with-bindings (alist fun)
+ "Call FUN with variables bound according to ALIST.
+ALIST is a list of the form ((VAR . VAL) ...)."
+ (let* ((rlist (reverse alist))
+ (vars (mapcar #'car rlist))
+ (vals (mapcar #'cdr rlist)))
+ (progv vars vals
+ (funcall fun))))
+
+(defmacro with-bindings (alist &body body)
+ "See `call-with-bindings'."
+ `(call-with-bindings ,alist (lambda () ,@body)))
+
+;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
+;;; RPC.
+
+(defmacro defslimefun (name arglist &body rest)
+ "A DEFUN for functions that Emacs can call by RPC."
+ `(progn
+ (defun ,name ,arglist ,@rest)
+ ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler…>
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',name :swank))))
+
+(defun missing-arg ()
+ "A function that the compiler knows will never to return a value.
+You can use (MISSING-ARG) as the initform for defstruct slots that
+must always be supplied. This way the :TYPE slot option need not
+include some arbitrary initial value like NIL."
+ (error "A required &KEY or &OPTIONAL argument was not supplied."))
+
+
+;;;; Hooks
+;;;
+;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
+;;; simple indirection. The interface is more CLish than the Emacs
+;;; Lisp one.
+
+(defmacro add-hook (place function)
+ "Add FUNCTION to the list of values on PLACE."
+ `(pushnew ,function ,place))
+
+(defun run-hook (functions &rest arguments)
+ "Call each of FUNCTIONS with ARGUMENTS."
+ (dolist (function functions)
+ (apply function arguments)))
+
+(defvar *new-connection-hook* '()
+ "This hook is run each time a connection is established.
+The connection structure is given as the argument.
+Backend code should treat the connection structure as opaque.")
+
+(defvar *connection-closed-hook* '()
+ "This hook is run when a connection is closed.
+The connection as passed as an argument.
+Backend code should treat the connection structure as opaque.")
+
+(defvar *pre-reply-hook* '()
+ "Hook run (without arguments) immediately before replying to an RPC.")
+
+(defvar *after-init-hook* '()
+ "Hook run after user init files are loaded.")
+
+(defun run-after-init-hook ()
+ (run-hook *after-init-hook*))
+
+
+;;;; 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).
+;;;
+
+(defstruct (connection
+ (:conc-name connection.)
+ (:print-function print-connection))
+ ;; Raw I/O stream of socket connection.
+ (socket-io (missing-arg) :type stream :read-only t)
+ ;; 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.
+ (user-input nil :type (or stream null))
+ (user-output nil :type (or stream null))
+ (user-io nil :type (or stream null))
+ ;; A stream that we use for *trace-output*; if nil, we user user-output.
+ (trace-output nil :type (or stream null))
+ ;; A stream where we send REPL results.
+ (repl-results nil :type (or stream null))
+ ;; In multithreaded systems we delegate certain tasks to specific
+ ;; threads. The `reader-thread' is responsible for reading network
+ ;; requests from Emacs and sending them to the `control-thread'; the
+ ;; `control-thread' is responsible for dispatching requests to the
+ ;; threads that should handle them; the `repl-thread' is the one
+ ;; that evaluates REPL expressions. The control thread dispatches
+ ;; all REPL evaluations to the REPL thread and for other requests it
+ ;; spawns new threads.
+ reader-thread
+ control-thread
+ repl-thread
+ ;; Callback functions:
+ ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
+ ;; from Emacs.
+ (serve-requests (missing-arg) :type function)
+ ;; (READ) is called to read and return one message from Emacs.
+ (read (missing-arg) :type function)
+ ;; (SEND OBJECT) is called to send one message to Emacs.
+ (send (missing-arg) :type function)
+ ;; (CLEANUP <this-connection>) is called when the connection is
+ ;; closed.
+ (cleanup nil :type (or null function))
+ ;; Cache of macro-indentation information that has been sent to Emacs.
+ ;; This is used for preparing deltas to update Emacs's knowledge.
+ ;; Maps: symbol -> indentation-specification
+ (indentation-cache (make-hash-table :test 'eq) :type hash-table)
+ ;; The list of packages represented in the cache:
+ (indentation-cache-packages '())
+ ;; The communication style used.
+ (communication-style nil :type (member nil :spawn :sigio :fd-handler))
+ ;; The coding system for network streams.
+ (coding-system ))
+
+(defun print-connection (conn stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (conn stream :type t :identity t)))
+
+(defvar *connections* '()
+ "List of all active connections, with the most recent at the front.")
+
+(defvar *emacs-connection* nil
+ "The connection to Emacs currently in use.")
+
+(defvar *swank-state-stack* '()
+ "A list of symbols describing the current state. Used for debugging
+and to detect situations where interrupts can be ignored.")
+
+(defun default-connection ()
+ "Return the 'default' Emacs connection.
+This connection can be used to talk with Emacs when no specific
+connection is in use, i.e. *EMACS-CONNECTION* is NIL.
+
+The default connection is defined (quite arbitrarily) as the most
+recently established one."
+ (first *connections*))
+
+(defslimefun state-stack ()
+ "Return the value of *SWANK-STATE-STACK*."
+ *swank-state-stack*)
+
+;; A conditions to include backtrace information
+(define-condition swank-error (error)
+ ((condition :initarg :condition :reader swank-error.condition)
+ (backtrace :initarg :backtrace :reader swank-error.backtrace))
+ (:report (lambda (condition stream)
+ (princ (swank-error.condition condition) stream))))
+
+(defun make-swank-error (condition)
+ (let ((bt (ignore-errors
+ (call-with-debugging-environment
+ (lambda () (backtrace 0 nil))))))
+ (make-condition 'swank-error :condition condition :backtrace bt)))
+
+(add-hook *new-connection-hook* 'notify-backend-of-connection)
+(defun notify-backend-of-connection (connection)
+ (declare (ignore connection))
+ (emacs-connected))
+
+
+;;;; Utilities
+
+;;;;; Helper macros
+
+(defmacro with-io-redirection ((connection) &body body)
+ "Execute BODY I/O redirection to CONNECTION.
+If *REDIRECT-IO* is true then all standard I/O streams are redirected."
+ `(maybe-call-with-io-redirection ,connection (lambda () ,@body)))
+
+(defun maybe-call-with-io-redirection (connection fun)
+ (if *redirect-io*
+ (call-with-redirected-io connection fun)
+ (funcall fun)))
+
+(defmacro with-connection ((connection) &body body)
+ "Execute BODY in the context of CONNECTION."
+ `(call-with-connection ,connection (lambda () ,@body)))
+
+(defun call-with-connection (connection fun)
+ (let ((*emacs-connection* connection))
+ (with-io-redirection (*emacs-connection*)
+ (call-with-debugger-hook #'swank-debugger-hook fun))))
+
+(defmacro without-interrupts (&body body)
+ `(call-without-interrupts (lambda () ,@body)))
+
+(defmacro destructure-case (value &rest patterns)
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (gensym "op-"))
+ (operands (gensym "rand-"))
+ (tmp (gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (case ,operator
+ ,@(loop for (pattern . body) in patterns collect
+ (if (eq pattern t)
+ `(t ,@body)
+ (destructuring-bind (op &rest rands) pattern
+ `(,op (destructuring-bind ,rands ,operands
+ ,@body)))))
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "destructure-case failed: ~S" ,tmp))))))))
+
+(defmacro with-temp-package (var &body body)
+ "Execute BODY with VAR bound to a temporary package.
+The package is deleted before returning."
+ `(let ((,var (make-package (gensym "TEMP-PACKAGE-"))))
+ (unwind-protect (progn ,@body)
+ (delete-package ,var))))
+
+(defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
+ "Just like do-symbols, but makes sure a symbol is visited only once."
+ (let ((seen-ht (gensym "SEEN-HT")))
+ `(let ((,seen-ht (make-hash-table :test #'eq)))
+ (do-symbols (,var ,package ,result-form)
+ (unless (gethash ,var ,seen-ht)
+ (setf (gethash ,var ,seen-ht) t)
+ ,@body)))))
+
+
+;;;;; Logging
+
+(defvar *log-events* nil)
+(defvar *log-output* *error-output*)
+(defvar *event-history* (make-array 40 :initial-element nil)
+ "A ring buffer to record events for better error messages.")
+(defvar *event-history-index* 0)
+(defvar *enable-event-history* t)
+
+(defun log-event (format-string &rest args)
+ "Write a message to *terminal-io* when *log-events* is non-nil.
+Useful for low level debugging."
+ (with-standard-io-syntax
+ (let ((*print-readably* nil)
+ (*print-pretty* nil)
+ (*package* *swank-io-package*))
+ (when *enable-event-history*
+ (setf (aref *event-history* *event-history-index*)
+ (format nil "~?" format-string args))
+ (setf *event-history-index*
+ (mod (1+ *event-history-index*) (length *event-history*))))
+ (when *log-events*
+ (apply #'format *log-output* format-string args)
+ (force-output *log-output*)))))
+
+(defun event-history-to-list ()
+ "Return the list of events (older events first)."
+ (let ((arr *event-history*)
+ (idx *event-history-index*))
+ (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
+
+(defun dump-event-history (stream)
+ (dolist (e (event-history-to-list))
+ (dump-event e stream)))
+
+(defun dump-event (event stream)
+ (cond ((stringp event)
+ (write-string (escape-non-ascii event) stream))
+ ((null event))
+ (t (format stream "Unexpected event: ~A~%" event))))
+
+(defun escape-non-ascii (string)
+ "Return a string like STRING but with non-ascii chars escaped."
+ (cond ((ascii-string-p string) string)
+ (t (with-output-to-string (out)
+ (loop for c across string do
+ (cond ((ascii-char-p c) (write-char c out))
+ (t (format out "\\x~4,'0X" (char-code c)))))))))
+
+(defun ascii-string-p (o)
+ (and (stringp o)
+ (every #'ascii-char-p o)))
+
+(defun ascii-char-p (c)
+ (<= (char-code c) 127))
+
+
+;;;;; Misc
+
+(defun length= (seq n)
+ "Test for whether SEQ contains N number of elements. I.e. it's equivalent
+ to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
+ efficiently implemented."
+ (etypecase seq
+ (list (do ((i n (1- i))
+ (list seq (cdr list)))
+ ((or (<= i 0) (null list))
+ (and (zerop i) (null list)))))
+ (sequence (= (length seq) n))))
+
+(defun ensure-list (thing)
+ (if (listp thing) thing (list thing)))
+
+(defun recursively-empty-p (list)
+ "Returns whether LIST consists only of arbitrarily nested empty lists."
+ (cond ((not (listp list)) nil)
+ ((null list) t)
+ (t (every #'recursively-empty-p list))))
+
+(defun maybecall (bool fn &rest args)
+ "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
+ (if bool (apply fn args) (values-list args)))
+
+(defun exactly-one-p (&rest values)
+ "If exactly one value in VALUES is non-NIL, this value is returned.
+Otherwise NIL is returned."
+ (let ((found nil))
+ (dolist (v values)
+ (when v (if found
+ (return-from exactly-one-p nil)
+ (setq found v))))
+ found))
+
+
+;;;;; Symbols
+
+(defun symbol-status (symbol &optional (package (symbol-package symbol)))
+ "Returns one of
+
+ :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
+
+ :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
+
+ :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
+ but is not _present_ in PACKAGE,
+
+ or NIL if SYMBOL is not _accessible_ in PACKAGE.
+
+
+Be aware not to get confused with :INTERNAL and how \"internal
+symbols\" are defined in the spec; there is a slight mismatch of
+definition with the Spec and what's commonly meant when talking
+about internal symbols most times. As the spec says:
+
+ In a package P, a symbol S is
+
+ _accessible_ if S is either _present_ in P itself or was
+ inherited from another package Q (which implies
+ that S is _external_ in Q.)
+
+ You can check that with: (AND (SYMBOL-STATUS S P) T)
+
+
+ _present_ if either P is the /home package/ of S or S has been
+ imported into P or exported from P by IMPORT, or
+ EXPORT respectively.
+
+ Or more simply, if S is not _inherited_.
+
+ You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
+ (AND STATUS
+ (NOT (EQ STATUS :INHERITED))))
+
+
+ _external_ if S is going to be inherited into any package that
+ /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
+ DEFPACKAGE.
+
+ Note that _external_ implies _present_, since to
+ make a symbol _external_, you'd have to use EXPORT
+ which will automatically make the symbol _present_.
+
+ You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
+
+
+ _internal_ if S is _accessible_ but not _external_.
+
+ You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
+ (AND STATUS
+ (NOT (EQ STATUS :EXTERNAL))))
+
+
+ Notice that this is *different* to
+ (EQ (SYMBOL-STATUS S P) :INTERNAL)
+ because what the spec considers _internal_ is split up into two
+ explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
+ CL:FIND-SYMBOL does.
+
+ The rationale is that most times when you speak about \"internal\"
+ symbols, you're actually not including the symbols inherited
+ from other packages, but only about the symbols directly specific
+ to the package in question.
+"
+ (when package ; may be NIL when symbol is completely uninterned.
+ (check-type symbol symbol) (check-type package package)
+ (multiple-value-bind (present-symbol status)
+ (find-symbol (symbol-name symbol) package)
+ (and (eq symbol present-symbol) status))))
+
+(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
+ "True if SYMBOL is external in PACKAGE.
+If PACKAGE is not specified, the home package of SYMBOL is used."
+ (eq (symbol-status symbol package) :external))
+
+
+(defun classify-symbol (symbol)
+ "Returns a list of classifiers that classify SYMBOL according
+to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a
+special variable.) The list may contain the following classification
+keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO,
+:SPECIAL-OPERATOR, and/or :PACKAGE"
+ (check-type symbol symbol)
+ (let (result)
+ (when (boundp symbol) (push :boundp result))
+ (when (fboundp symbol) (push :fboundp result))
+ (when (find-class symbol nil) (push :class result))
+ (when (macro-function symbol) (push :macro result))
+ (when (special-operator-p symbol) (push :special-operator result))
+ (when (find-package symbol) (push :package result))
+ (when (typep (ignore-errors (fdefinition symbol))
+ 'generic-function)
+ (push :generic-function result))
+ result))
+
+(defun symbol-classification->string (flags)
+ (format nil "~A~A~A~A~A~A~A"
+ (if (member :boundp flags) "b" "-")
+ (if (member :fboundp flags) "f" "-")
+ (if (member :generic-function flags) "g" "-")
+ (if (member :class flags) "c" "-")
+ (if (member :macro flags) "m" "-")
+ (if (member :special-operator flags) "s" "-")
+ (if (member :package flags) "p" "-")))
+
+
+;;;; TCP Server
+
+(defvar *use-dedicated-output-stream* nil
+ "When T swank will attempt to create a second connection to
+ Emacs which is used just to send output.")
+
+(defvar *dedicated-output-stream-port* 0
+ "Which port we should use for the dedicated output stream.")
+
+(defvar *communication-style* (preferred-communication-style))
+
+(defvar *dont-close* nil
+ "Default value of :dont-close argument to start-server and
+ create-server.")
+
+(defvar *dedicated-output-stream-buffering*
+ (if (eq *communication-style* :spawn) :full :none)
+ "The buffering scheme that should be used for the output stream.
+Valid values are :none, :line, and :full.")
+
+(defvar *coding-system* "iso-latin-1-unix")
+
+(defvar *listener-sockets* nil
+ "A property list of lists containing style, socket pairs used
+ by swank server listeners, keyed on socket port number. They
+ are used to close sockets on server shutdown or restart.")
+
+(defun start-server (port-file &key (style *communication-style*)
+ (dont-close *dont-close*)
+ (coding-system *coding-system*))
+ "Start the server and write the listen port number to PORT-FILE.
+This is the entry point for Emacs."
+ (setup-server 0 (lambda (port)
+ (announce-server-port port-file port))
+ style dont-close
+ (find-external-format-or-lose coding-system)))
+
+(defun create-server (&key (port default-server-port)
+ (style *communication-style*)
+ (dont-close *dont-close*)
+ (coding-system *coding-system*))
+ "Start a SWANK server on PORT running in STYLE.
+If DONT-CLOSE is true then the listen socket will accept multiple
+connections, otherwise it will be closed after the first."
+ (setup-server port #'simple-announce-function style dont-close
+ (find-external-format-or-lose coding-system)))
+
+(defun find-external-format-or-lose (coding-system)
+ (or (find-external-format coding-system)
+ (error "Unsupported coding system: ~s" coding-system)))
+
+(defparameter *loopback-interface* "127.0.0.1")
+
+(defun setup-server (port announce-fn style dont-close external-format)
+ (declare (type function announce-fn))
+ (let* ((socket (create-socket *loopback-interface* port))
+ (local-port (local-port socket)))
+ (funcall announce-fn local-port)
+ (flet ((serve ()
+ (serve-connection socket style dont-close external-format)))
+ (ecase style
+ (:spawn
+ (initialize-multiprocessing
+ (lambda ()
+ (spawn (lambda ()
+ (loop do (ignore-errors (serve)) while dont-close))
+ :name (concatenate 'string "Swank "
+ (princ-to-string port))))))
+ ((:fd-handler :sigio)
+ (add-fd-handler socket (lambda () (serve))))
+ ((nil) (loop do (serve) while dont-close)))
+ (setf (getf *listener-sockets* port) (list style socket))
+ local-port)))
+
+(defun stop-server (port)
+ "Stop server running on PORT."
+ (let* ((socket-description (getf *listener-sockets* port))
+ (style (first socket-description))
+ (socket (second socket-description)))
+ (ecase style
+ (:spawn
+ (let ((thread-position
+ (position-if
+ (lambda (x)
+ (string-equal (first x)
+ (concatenate 'string "Swank "
+ (princ-to-string port))))
+ (list-threads))))
+ (when thread-position
+ (kill-nth-thread thread-position)
+ (close-socket socket)
+ (remf *listener-sockets* port))))
+ ((:fd-handler :sigio)
+ (remove-fd-handlers socket)
+ (close-socket socket)
+ (remf *listener-sockets* port)))))
+
+(defun restart-server (&key (port default-server-port)
+ (style *communication-style*)
+ (dont-close *dont-close*)
+ (coding-system *coding-system*))
+ "Stop the server listening on PORT, then start a new SWANK server
+on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
+will accept multiple connections, otherwise it will be closed after the
+first."
+ (stop-server port)
+ (sleep 5)
+ (create-server :port port :style style :dont-close dont-close
+ :coding-system coding-system))
+
+
+(defun serve-connection (socket style dont-close external-format)
+ (let ((closed-socket-p nil))
+ (unwind-protect
+ (let ((client (accept-authenticated-connection
+ socket :external-format external-format)))
+ (unless dont-close
+ (close-socket socket)
+ (setf closed-socket-p t))
+ (let ((connection (create-connection client style)))
+ (run-hook *new-connection-hook* connection)
+ (push connection *connections*)
+ (serve-requests connection)))
+ (unless (or dont-close closed-socket-p)
+ (close-socket socket)))))
+
+(defun accept-authenticated-connection (&rest args)
+ (let ((new (apply #'accept-connection args))
+ (success nil))
+ (unwind-protect
+ (let ((secret (slime-secret)))
+ (when secret
+ (set-stream-timeout new 20)
+ (let ((first-val (decode-message new)))
+ (unless (and (stringp first-val) (string= first-val secret))
+ (error "Incoming connection doesn't know the password."))))
+ (set-stream-timeout new nil)
+ (setf success t))
+ (unless success
+ (close new :abort t)))
+ new))
+
+(defun slime-secret ()
+ "Finds the magic secret from the user's home directory. Returns nil
+if the file doesn't exist; otherwise the first line of the file."
+ (with-open-file (in
+ (merge-pathnames (user-homedir-pathname) #p".slime-secret")
+ :if-does-not-exist nil)
+ (and in (read-line in nil ""))))
+
+(defun serve-requests (connection)
+ "Read and process all requests on connections."
+ (funcall (connection.serve-requests connection) connection))
+
+(defun announce-server-port (file port)
+ (with-open-file (s file
+ :direction :output
+ :if-exists :error
+ :if-does-not-exist :create)
+ (format s "~S~%" port))
+ (simple-announce-function port))
+
+(defun simple-announce-function (port)
+ (when *swank-debug-p*
+ (format *log-output* "~&;; Swank started at port: ~D.~%" port)
+ (force-output *log-output*)))
+
+(defun open-streams (connection)
+ "Return the 5 streams for IO redirection:
+DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
+ (multiple-value-bind (output-fn dedicated-output)
+ (make-output-function connection)
+ (let ((input-fn
+ (lambda ()
+ (with-connection (connection)
+ (with-simple-restart (abort-read
+ "Abort reading input from Emacs.")
+ (read-user-input-from-emacs))))))
+ (multiple-value-bind (in out) (make-fn-streams input-fn output-fn)
+ (let ((out (or dedicated-output out)))
+ (let ((io (make-two-way-stream in out)))
+ (mapc #'make-stream-interactive (list in out io))
+ (let ((repl-results
+ (make-output-stream-for-target connection :repl-result)))
+ (values dedicated-output in out io repl-results))))))))
+
+(defun make-output-function (connection)
+ "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
+ (connection.socket-io connection))))
+ (values (lambda (string)
+ (write-string string stream)
+ (force-output stream))
+ stream))
+ (values (lambda (string)
+ (with-connection (connection)
+ (with-simple-restart
+ (abort "Abort sending output to Emacs.")
+ (send-to-emacs `(:write-string ,string)))))
+ nil)))
+
+(defun make-output-function-for-target (connection target)
+ "Create a function to send user output to a specific TARGET in Emacs."
+ (lambda (string)
+ (with-connection (connection)
+ (with-simple-restart
+ (abort "Abort sending output to Emacs.")
+ (send-to-emacs `(:write-string ,string ,target))))))
+
+(defun make-output-stream-for-target (connection target)
+ "Create a stream that sends output to a specific TARGET in Emacs."
+ (nth-value 1 (make-fn-streams
+ (lambda ()
+ (error "Should never be called"))
+ (make-output-function-for-target connection target))))
+
+(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."
+ (let ((socket (create-socket *loopback-interface*
+ *dedicated-output-stream-port*)))
+ (unwind-protect
+ (let ((port (local-port socket)))
+ (encode-message `(:open-dedicated-output-stream ,port) socket-io)
+ (let ((dedicated (accept-authenticated-connection
+ socket
+ :external-format
+ (or (ignore-errors
+ (stream-external-format socket-io))
+ :default)
+ :buffering *dedicated-output-stream-buffering*
+ :timeout 30)))
+ (close-socket socket)
+ (setf socket nil)
+ dedicated))
+ (when socket
+ (close-socket socket)))))
+
+(defvar *sldb-quit-restart* 'abort
+ "What restart should swank attempt to invoke when the user sldb-quits.")
+
+(defun handle-request (connection)
+ "Read and process one request. The processing is done in the extent
+of the toplevel restart."
+ (assert (null *swank-state-stack*))
+ (let ((*swank-state-stack* '(:handle-request)))
+ (with-connection (connection)
+ (with-simple-restart (abort "Return to SLIME's top level.")
+ (let ((*sldb-quit-restart* (find-restart 'abort)))
+ (read-from-emacs))))))
+
+(defun current-socket-io ()
+ (connection.socket-io *emacs-connection*))
+
+(defun close-connection (c &optional condition backtrace)
+ (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
+ (let ((cleanup (connection.cleanup c)))
+ (when cleanup
+ (funcall cleanup c)))
+ (close (connection.socket-io c))
+ (when (connection.dedicated-output c)
+ (close (connection.dedicated-output c)))
+ (setf *connections* (remove c *connections*))
+ (run-hook *connection-closed-hook* c)
+ (when (and condition (not (typep condition 'end-of-file)))
+ (finish-output *log-output*)
+ (format *log-output* "~&;; Event history start:~%")
+ (dump-event-history *log-output*)
+ (format *log-output* ";; Event history end.~%~
+ ;; Backtrace:~%~{~A~%~}~
+ ;; Connection to Emacs lost. [~%~
+ ;; condition: ~A~%~
+ ;; type: ~S~%~
+ ;; encoding: ~A style: ~S dedicated: ~S]~%"
+ backtrace
+ (escape-non-ascii (safe-condition-message condition) )
+ (type-of condition)
+ (ignore-errors (stream-external-format (connection.socket-io c)))
+ (connection.communication-style c)
+ *use-dedicated-output-stream*)
+ (finish-output *log-output*)))
+
+(defvar *debug-on-swank-error* nil
+ "When non-nil internal swank errors will drop to a
+ debugger (not an sldb buffer). Do not set this to T unless you
+ want to debug swank internals.")
+
+(defmacro with-reader-error-handler ((connection) &body body)
+ (let ((con (gensym))
+ (blck (gensym)))
+ `(let ((,con ,connection))
+ (block ,blck
+ (handler-bind ((swank-error
+ (lambda (e)
+ (if *debug-on-swank-error*
+ (invoke-debugger e)
+ (return-from ,blck
+ (close-connection
+ ,con
+ (swank-error.condition e)
+ (swank-error.backtrace e)))))))
+ (progn ,@body))))))
+
+(defslimefun simple-break ()
+ (with-simple-restart (continue "Continue from interrupt.")
+ (call-with-debugger-hook
+ #'swank-debugger-hook
+ (lambda ()
+ (invoke-debugger
+ (make-condition 'simple-error
+ :format-control "Interrupt from Emacs")))))
+ nil)
+
+;;;;;; Thread based communication
+
+(defvar *active-threads* '())
+
+(defun read-loop (control-thread input-stream connection)
+ (with-reader-error-handler (connection)
+ (loop (send control-thread (decode-message input-stream)))))
+
+(defun dispatch-loop (socket-io connection)
+ (let ((*emacs-connection* connection))
+ (handler-bind ((error (lambda (e)
+ (if *debug-on-swank-error*
+ (invoke-debugger e)
+ (return-from dispatch-loop
+ (close-connection connection e))))))
+ (loop (dispatch-event (receive) socket-io)))))
+
+(defun repl-thread (connection)
+ (let ((thread (connection.repl-thread connection)))
+ (when (not thread)
+ (log-event "ERROR: repl-thread is nil"))
+ (assert thread)
+ (cond ((thread-alive-p thread)
+ thread)
+ (t
+ (setf (connection.repl-thread connection)
+ (spawn-repl-thread connection "new-repl-thread"))))))
+
+(defun find-worker-thread (id)
+ (etypecase id
+ ((member t)
+ (car *active-threads*))
+ ((member :repl-thread)
+ (repl-thread *emacs-connection*))
+ (fixnum
+ (find-thread id))))
+
+(defun interrupt-worker-thread (id)
+ (let ((thread (or (find-worker-thread id)
+ (repl-thread *emacs-connection*))))
+ (interrupt-thread thread #'simple-break)))
+
+(defun thread-for-evaluation (id)
+ "Find or create a thread to evaluate the next request."
+ (let ((c *emacs-connection*))
+ (etypecase id
+ ((member t)
+ (spawn-worker-thread c))
+ ((member :repl-thread)
+ (repl-thread c))
+ (fixnum
+ (find-thread id)))))
+
+(defun spawn-worker-thread (connection)
+ (spawn (lambda ()
+ (with-bindings *default-worker-thread-bindings*
+ (handle-request connection)))
+ :name "worker"))
+
+(defun spawn-repl-thread (connection name)
+ (spawn (lambda ()
+ (with-bindings *default-worker-thread-bindings*
+ (repl-loop connection)))
+ :name name))
+
+(defun dispatch-event (event socket-io)
+ "Handle an event triggered either by Emacs or within Lisp."
+ (log-event "DISPATCHING: ~S~%" event)
+ (destructure-case event
+ ((:emacs-rex form package thread-id id)
+ (let ((thread (thread-for-evaluation thread-id)))
+ (push thread *active-threads*)
+ (send thread `(eval-for-emacs ,form ,package ,id))))
+ ((:return thread &rest args)
+ (let ((tail (member thread *active-threads*)))
+ (setq *active-threads* (nconc (ldiff *active-threads* tail)
+ (cdr tail))))
+ (encode-message `(:return ,@args) socket-io))
+ ((:emacs-interrupt thread-id)
+ (interrupt-worker-thread thread-id))
+ (((:debug :debug-condition :debug-activate :debug-return)
+ thread &rest args)
+ (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
+ ((:read-string thread &rest args)
+ (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
+ ((:y-or-n-p thread &rest args)
+ (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
+ ((:read-aborted thread &rest args)
+ (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
+ ((:emacs-return-string thread-id tag string)
+ (send (find-thread thread-id) `(take-input ,tag ,string)))
+ ((:eval thread &rest args)
+ (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
+ ((:emacs-return thread-id tag value)
+ (send (find-thread thread-id) `(take-input ,tag ,value)))
+ (((:write-string :presentation-start :presentation-end
+ :new-package :new-features :ed :%apply :indentation-update
+ :eval-no-wait :background-message :inspect)
+ &rest _)
+ (declare (ignore _))
+ (encode-message event socket-io))))
+
+(defun spawn-threads-for-connection (connection)
+ (macrolet ((without-debugger-hook (&body body)
+ `(call-with-debugger-hook nil (lambda () ,@body))))
+ (let* ((socket-io (connection.socket-io connection))
+ (control-thread (spawn (lambda ()
+ (without-debugger-hook
+ (dispatch-loop socket-io connection)))
+ :name "control-thread")))
+ (setf (connection.control-thread connection) control-thread)
+ (let ((reader-thread (spawn (lambda ()
+ (let ((go (receive)))
+ (assert (eq go 'accept-input)))
+ (without-debugger-hook
+ (read-loop control-thread socket-io
+ connection)))
+ :name "reader-thread"))
+ (repl-thread (spawn-repl-thread connection "repl-thread")))
+ (setf (connection.repl-thread connection) repl-thread)
+ (setf (connection.reader-thread connection) reader-thread)
+ (send reader-thread 'accept-input)
+ connection))))
+
+(defun cleanup-connection-threads (connection)
+ (let ((threads (list (connection.repl-thread connection)
+ (connection.reader-thread connection)
+ (connection.control-thread connection))))
+ (dolist (thread threads)
+ (when (and thread
+ (thread-alive-p thread)
+ (not (equal (current-thread) thread)))
+ (kill-thread thread)))))
+
+(defun repl-loop (connection)
+ (loop (handle-request connection)))
+
+(defun process-available-input (stream fn)
+ (loop while (input-available-p stream)
+ do (funcall fn)))
+
+(defun input-available-p (stream)
+ ;; return true iff we can read from STREAM without waiting or if we
+ ;; hit EOF
+ (let ((c (read-char-no-hang stream nil :eof)))
+ (cond ((not c) nil)
+ ((eq c :eof) t)
+ (t
+ (unread-char c stream)
+ t))))
+
+;;;;;; Signal driven IO
+
+(defun install-sigio-handler (connection)
+ (let ((client (connection.socket-io connection)))
+ (flet ((handler ()
+ (cond ((null *swank-state-stack*)
+ (with-reader-error-handler (connection)
+ (process-available-input
+ client (lambda () (handle-request connection)))))
+ ((eq (car *swank-state-stack*) :read-next-form))
+ (t (process-available-input client #'read-from-emacs)))))
+ (add-sigio-handler client #'handler)
+ (handler))))
+
+(defun deinstall-sigio-handler (connection)
+ (remove-sigio-handlers (connection.socket-io connection)))
+
+;;;;;; SERVE-EVENT based IO
+
+(defun install-fd-handler (connection)
+ (let ((client (connection.socket-io connection)))
+ (flet ((handler ()
+ (cond ((null *swank-state-stack*)
+ (with-reader-error-handler (connection)
+ (process-available-input
+ client (lambda () (handle-request connection)))))
+ ((eq (car *swank-state-stack*) :read-next-form))
+ (t
+ (process-available-input client #'read-from-emacs)))))
+ ;;;; handle sigint
+ ;;(install-debugger-globally
+ ;; (lambda (c h)
+ ;; (with-reader-error-handler (connection)
+ ;; (block debugger
+ ;; (with-connection (connection)
+ ;; (swank-debugger-hook c h)
+ ;; (return-from debugger))
+ ;; (abort)))))
+ (add-fd-handler client #'handler)
+ (handler))))
+
+(defun deinstall-fd-handler (connection)
+ (remove-fd-handlers (connection.socket-io connection)))
+
+;;;;;; Simple sequential IO
+
+(defun simple-serve-requests (connection)
+ (unwind-protect
+ (with-simple-restart (close-connection "Close SLIME connection")
+ (with-reader-error-handler (connection)
+ (loop
+ (handle-request connection))))
+ (close-connection connection)))
+
+(defun read-from-socket-io ()
+ (let ((event (decode-message (current-socket-io))))
+ (log-event "DISPATCHING: ~S~%" event)
+ (destructure-case event
+ ((:emacs-rex form package thread id)
+ (declare (ignore thread))
+ `(eval-for-emacs ,form ,package ,id))
+ ((:emacs-interrupt thread)
+ (declare (ignore thread))
+ '(simple-break))
+ ((:emacs-return-string thread tag string)
+ (declare (ignore thread))
+ `(take-input ,tag ,string))
+ ((:emacs-return thread tag value)
+ (declare (ignore thread))
+ `(take-input ,tag ,value)))))
+
+(defun send-to-socket-io (event)
+ (log-event "DISPATCHING: ~S~%" event)
+ (flet ((send (o)
+ (without-interrupts
+ (encode-message o (current-socket-io)))))
+ (destructure-case event
+ (((:debug-activate :debug :debug-return :read-string :read-aborted
+ :y-or-n-p :eval)
+ thread &rest args)
+ (declare (ignore thread))
+ (send `(,(car event) 0 ,@args)))
+ ((:return thread &rest args)
+ (declare (ignore thread))
+ (send `(:return ,@args)))
+ (((:write-string :new-package :new-features :debug-condition
+ :presentation-start :presentation-end
+ :indentation-update :ed :%apply :eval-no-wait
+ :background-message :inspect)
+ &rest _)
+ (declare (ignore _))
+ (send event)))))
+
+(defun initialize-streams-for-connection (connection)
+ (multiple-value-bind (dedicated in out io repl-results)
+ (open-streams connection)
+ (setf (connection.dedicated-output connection) dedicated
+ (connection.user-io connection) io
+ (connection.user-output connection) out
+ (connection.user-input connection) in
+ (connection.repl-results connection) repl-results)
+ connection))
+
+(defun create-connection (socket-io style)
+ (let ((success nil))
+ (unwind-protect
+ (let ((c (ecase style
+ (:spawn
+ (make-connection :socket-io socket-io
+ :read #'read-from-control-thread
+ :send #'send-to-control-thread
+ :serve-requests #'spawn-threads-for-connection
+ :cleanup #'cleanup-connection-threads))
+ (:sigio
+ (make-connection :socket-io socket-io
+ :read #'read-from-socket-io
+ :send #'send-to-socket-io
+ :serve-requests #'install-sigio-handler
+ :cleanup #'deinstall-sigio-handler))
+ (:fd-handler
+ (make-connection :socket-io socket-io
+ :read #'read-from-socket-io
+ :send #'send-to-socket-io
+ :serve-requests #'install-fd-handler
+ :cleanup #'deinstall-fd-handler))
+ ((nil)
+ (make-connection :socket-io socket-io
+ :read #'read-from-socket-io
+ :send #'send-to-socket-io
+ :serve-requests #'simple-serve-requests)))))
+ (setf (connection.communication-style c) style)
+ (initialize-streams-for-connection c)
+ (setf success t)
+ c)
+ (unless success
+ (close socket-io :abort t)))))
+
+
+;;;; IO to Emacs
+;;;
+;;; This code handles redirection of the standard I/O streams
+;;; (`*standard-output*', etc) into Emacs. The `connection' structure
+;;; contains the appropriate streams, so all we have to do is make the
+;;; right bindings.
+
+;;;;; Global I/O redirection framework
+;;;
+;;; Optionally, the top-level global bindings of the standard streams
+;;; can be assigned to be redirected to Emacs. When Emacs connects we
+;;; redirect the streams into the connection, and they keep going into
+;;; that connection even if more are established. If the connection
+;;; handling the streams closes then another is chosen, or if there
+;;; are no connections then we revert to the original (real) streams.
+;;;
+;;; It is slightly tricky to assign the global values of standard
+;;; streams because they are often shadowed by dynamic bindings. We
+;;; solve this problem by introducing an extra indirection via synonym
+;;; streams, so that *STANDARD-INPUT* is a synonym stream to
+;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
+;;; variables, so they can always be assigned to affect a global
+;;; change.
+
+(defvar *globally-redirect-io* nil
+ "When non-nil globally redirect all standard streams to Emacs.")
+
+;;;;; Global redirection setup
+
+(defvar *saved-global-streams* '()
+ "A plist to save and restore redirected stream objects.
+E.g. the value for '*standard-output* holds the stream object
+for *standard-output* before we install our redirection.")
+
+(defun setup-stream-indirection (stream-var &optional stream)
+ "Setup redirection scaffolding for a global stream variable.
+Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
+
+1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
+
+2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
+*STANDARD-INPUT*.
+
+3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
+*CURRENT-STANDARD-INPUT*.
+
+This has the effect of making *CURRENT-STANDARD-INPUT* contain the
+effective global value for *STANDARD-INPUT*. This way we can assign
+the effective global value even when *STANDARD-INPUT* is shadowed by a
+dynamic binding."
+ (let ((current-stream-var (prefixed-var '#:current stream-var))
+ (stream (or stream (symbol-value stream-var))))
+ ;; Save the real stream value for the future.
+ (setf (getf *saved-global-streams* stream-var) stream)
+ ;; Define a new variable for the effective stream.
+ ;; This can be reassigned.
+ (proclaim `(special ,current-stream-var))
+ (set current-stream-var stream)
+ ;; Assign the real binding as a synonym for the current one.
+ (set stream-var (make-synonym-stream current-stream-var))))
+
+(defun prefixed-var (prefix variable-symbol)
+ "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
+ (let ((basename (subseq (symbol-name variable-symbol) 1)))
+ (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
+
+(defvar *standard-output-streams*
+ '(*standard-output* *error-output* *trace-output*)
+ "The symbols naming standard output streams.")
+
+(defvar *standard-input-streams*
+ '(*standard-input*)
+ "The symbols naming standard input streams.")
+
+(defvar *standard-io-streams*
+ '(*debug-io* *query-io* *terminal-io*)
+ "The symbols naming standard io streams.")
+
+(defun init-global-stream-redirection ()
+ (when *globally-redirect-io*
+ (mapc #'setup-stream-indirection
+ (append *standard-output-streams*
+ *standard-input-streams*
+ *standard-io-streams*))))
+
+(add-hook *after-init-hook* 'init-global-stream-redirection)
+
+(defun globally-redirect-io-to-connection (connection)
+ "Set the standard I/O streams to redirect to CONNECTION.
+Assigns *CURRENT-<STREAM>* for all standard streams."
+ (dolist (o *standard-output-streams*)
+ (set (prefixed-var '#:current o)
+ (connection.user-output connection)))
+ ;; FIXME: If we redirect standard input to Emacs then we get the
+ ;; regular Lisp top-level trying to read from our REPL.
+ ;;
+ ;; Perhaps the ideal would be for the real top-level to run in a
+ ;; thread with local bindings for all the standard streams. Failing
+ ;; that we probably would like to inhibit it from reading while
+ ;; Emacs is connected.
+ ;;
+ ;; Meanwhile we just leave *standard-input* alone.
+ #+NIL
+ (dolist (i *standard-input-streams*)
+ (set (prefixed-var '#:current i)
+ (connection.user-input connection)))
+ (dolist (io *standard-io-streams*)
+ (set (prefixed-var '#:current io)
+ (connection.user-io connection))))
+
+(defun revert-global-io-redirection ()
+ "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
+ (dolist (stream-var (append *standard-output-streams*
+ *standard-input-streams*
+ *standard-io-streams*))
+ (set (prefixed-var '#:current stream-var)
+ (getf *saved-global-streams* stream-var))))
+
+;;;;; Global redirection hooks
+
+(defvar *global-stdio-connection* nil
+ "The connection to which standard I/O streams are globally redirected.
+NIL if streams are not globally redirected.")
+
+(defun maybe-redirect-global-io (connection)
+ "Consider globally redirecting to a newly-established CONNECTION."
+ (when (and *globally-redirect-io* (null *global-stdio-connection*))
+ (setq *global-stdio-connection* connection)
+ (globally-redirect-io-to-connection connection)))
+
+(defun update-redirection-after-close (closed-connection)
+ "Update redirection after a connection closes."
+ (check-type closed-connection connection)
+ (when (eq *global-stdio-connection* closed-connection)
+ (if (and (default-connection) *globally-redirect-io*)
+ ;; Redirect to another connection.
+ (globally-redirect-io-to-connection (default-connection))
+ ;; No more connections, revert to the real streams.
+ (progn (revert-global-io-redirection)
+ (setq *global-stdio-connection* nil)))))
+
+(add-hook *new-connection-hook* 'maybe-redirect-global-io)
+(add-hook *connection-closed-hook* 'update-redirection-after-close)
+
+;;;;; Redirection during requests
+;;;
+;;; We always redirect the standard streams to Emacs while evaluating
+;;; an RPC. This is done with simple dynamic bindings.
+
+(defun call-with-redirected-io (connection function)
+ "Call FUNCTION with I/O streams redirected via CONNECTION."
+ (declare (type function function))
+ (let* ((io (connection.user-io connection))
+ (in (connection.user-input connection))
+ (out (connection.user-output connection))
+ (trace (or (connection.trace-output connection) out))
+ (*standard-output* out)
+ (*error-output* out)
+ (*trace-output* trace)
+ (*debug-io* io)
+ (*query-io* io)
+ (*standard-input* in)
+ (*terminal-io* io))
+ (funcall function)))
+
+(defun read-from-emacs ()
+ "Read and process a request from Emacs."
+ (apply #'funcall (funcall (connection.read *emacs-connection*))))
+
+(defun read-from-control-thread ()
+ (receive))
+
+(defun decode-message (stream)
+ "Read an S-expression from STREAM using the SLIME protocol."
+ (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
+ (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
+ (let* ((length (decode-message-length stream))
+ (string (make-string length))
+ (pos (read-sequence string stream)))
+ (assert (= pos length) ()
+ "Short read: length=~D pos=~D" length pos)
+ (log-event "READ: ~S~%" string)
+ (read-form string)))))
+
+(defun decode-message-length (stream)
+ (let ((buffer (make-string 6)))
+ (dotimes (i 6)
+ (setf (aref buffer i) (read-char stream)))
+ (parse-integer buffer :radix #x10)))
+
+(defun read-form (string)
+ (with-standard-io-syntax
+ (let ((*package* *swank-io-package*))
+ (read-from-string string))))
+
+(defvar *slime-features* nil
+ "The feature list that has been sent to Emacs.")
+
+(defun send-to-emacs (object)
+ "Send OBJECT to Emacs."
+ (funcall (connection.send *emacs-connection*) object))
+
+(defun send-oob-to-emacs (object)
+ (send-to-emacs object))
+
+(defun send-to-control-thread (object)
+ (send (connection.control-thread *emacs-connection*) object))
+
+(defun encode-message (message stream)
+ (let* ((string (prin1-to-string-for-emacs message))
+ (length (length string)))
+ (log-event "WRITE: ~A~%" string)
+ (let ((*print-pretty* nil))
+ (format stream "~6,'0x" length))
+ (write-string string stream)
+ ;;(terpri stream)
+ (finish-output stream)))
+
+(defun prin1-to-string-for-emacs (object)
+ (with-standard-io-syntax
+ (let ((*print-case* :downcase)
+ (*print-readably* nil)
+ (*print-pretty* nil)
+ (*package* *swank-io-package*))
+ (prin1-to-string object))))
+
+(defun force-user-output ()
+ (force-output (connection.user-io *emacs-connection*))
+ (finish-output (connection.user-output *emacs-connection*)))
+
+(defun clear-user-input ()
+ (clear-input (connection.user-input *emacs-connection*)))
+
+(defvar *read-input-catch-tag* 0)
+
+(defun intern-catch-tag (tag)
+ ;; fixnums aren't eq in ABCL, so we use intern to create tags
+ (intern (format nil "~D" tag) :swank))
+
+(defun read-user-input-from-emacs ()
+ (let ((tag (incf *read-input-catch-tag*)))
+ (force-output)
+ (send-to-emacs `(:read-string ,(current-thread) ,tag))
+ (let ((ok nil))
+ (unwind-protect
+ (prog1 (catch (intern-catch-tag tag)
+ (loop (read-from-emacs)))
+ (setq ok t))
+ (unless ok
+ (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
+
+(defun y-or-n-p-in-emacs (format-string &rest arguments)
+ "Like y-or-n-p, but ask in the Emacs minibuffer."
+ (let ((tag (incf *read-input-catch-tag*))
+ (question (apply #'format nil format-string arguments)))
+ (force-output)
+ (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
+ (catch (intern-catch-tag tag)
+ (loop (read-from-emacs)))))
+
+(defslimefun take-input (tag input)
+ "Return the string INPUT to the continuation TAG."
+ (throw (intern-catch-tag tag) input))
+
+(defun process-form-for-emacs (form)
+ "Returns a string which emacs will read as equivalent to
+FORM. FORM can contain lists, strings, characters, symbols and
+numbers.
+
+Characters are converted emacs' ?<char> notaion, strings are left
+as they are (except for espacing any nested \" chars, numbers are
+printed in base 10 and symbols are printed as their symbol-name
+converted to lower case."
+ (etypecase form
+ (string (format nil "~S" form))
+ (cons (format nil "(~A . ~A)"
+ (process-form-for-emacs (car form))
+ (process-form-for-emacs (cdr form))))
+ (character (format nil "?~C" form))
+ (symbol (concatenate 'string (when (eq (symbol-package form)
+ #.(find-package "KEYWORD"))
+ ":")
+ (string-downcase (symbol-name form))))
+ (number (let ((*print-base* 10))
+ (princ-to-string form)))))
+
+(defun eval-in-emacs (form &optional nowait)
+ "Eval FORM in Emacs."
+ (cond (nowait
+ (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
+ (t
+ (force-output)
+ (let* ((tag (incf *read-input-catch-tag*))
+ (value (catch (intern-catch-tag tag)
+ (send-to-emacs
+ `(:eval ,(current-thread) ,tag
+ ,(process-form-for-emacs form)))
+ (loop (read-from-emacs)))))
+ (destructure-case value
+ ((:ok value) value)
+ ((:abort) (abort)))))))
+
+(defvar *swank-wire-protocol-version* nil
+ "The version of the swank/slime communication protocol.")
+
+(defslimefun connection-info ()
+ "Return a key-value list of the form:
+\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
+PID: is the process-id of Lisp process (or nil, depending on the STYLE)
+STYLE: the communication style
+LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
+FEATURES: a list of keywords
+PACKAGE: a list (&key NAME PROMPT)
+VERSION: the protocol version"
+ (setq *slime-features* *features*)
+ `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
+ :lisp-implementation (:type ,(lisp-implementation-type)
+ :name ,(lisp-implementation-type-name)
+ :version ,(lisp-implementation-version))
+ :machine (:instance ,(machine-instance)
+ :type ,(machine-type)
+ :version ,(machine-version))
+ :features ,(features-for-emacs)
+ :modules ,*modules*
+ :package (:name ,(package-name *package*)
+ :prompt ,(package-string-for-prompt *package*))
+ :version ,*swank-wire-protocol-version*))
+
+(defslimefun io-speed-test (&optional (n 5000) (m 1))
+ (let* ((s *standard-output*)
+ (*trace-output* (make-broadcast-stream s *log-output*)))
+ (time (progn
+ (dotimes (i n)
+ (format s "~D abcdefghijklm~%" i)
+ (when (zerop (mod n m))
+ (force-output s)))
+ (finish-output s)
+ (when *emacs-connection*
+ (eval-in-emacs '(message "done.")))))
+ (terpri *trace-output*)
+ (finish-output *trace-output*)
+ nil))
+
+
+;;;; Reading and printing
+
+(defmacro define-special (name doc)
+ "Define a special variable NAME with doc string DOC.
+This is like defvar, but NAME will not be initialized."
+ `(progn
+ (defvar ,name)
+ (setf (documentation ',name 'variable) ,doc)))
+
+(define-special *buffer-package*
+ "Package corresponding to slime-buffer-package.
+
+EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
+buffer are best read in this package. See also FROM-STRING and TO-STRING.")
+
+(define-special *buffer-readtable*
+ "Readtable associated with the current buffer")
+
+(defmacro with-buffer-syntax ((&rest _) &body body)
+ "Execute BODY with appropriate *package* and *readtable* bindings.
+
+This should be used for code that is conceptionally executed in an
+Emacs buffer."
+ (destructuring-bind () _
+ `(call-with-buffer-syntax (lambda () ,@body))))
+
+(defun call-with-buffer-syntax (fun)
+ (let ((*package* *buffer-package*))
+ ;; Don't shadow *readtable* unnecessarily because that prevents
+ ;; the user from assigning to it.
+ (if (eq *readtable* *buffer-readtable*)
+ (call-with-syntax-hooks fun)
+ (let ((*readtable* *buffer-readtable*))
+ (call-with-syntax-hooks fun)))))
+
+(defun to-string (object)
+ "Write OBJECT in the *BUFFER-PACKAGE*.
+The result may not be readable. Handles problems with PRINT-OBJECT methods
+gracefully."
+ (with-buffer-syntax ()
+ (let ((*print-readably* nil))
+ (handler-case
+ (prin1-to-string object)
+ (error ()
+ (with-output-to-string (s)
+ (print-unreadable-object (object s :type t :identity t)
+ (princ "<<error printing object>>" s))))))))
+
+(defun from-string (string)
+ "Read string in the *BUFFER-PACKAGE*"
+ (with-buffer-syntax ()
+ (let ((*read-suppress* nil))
+ (read-from-string string))))
+
+(defun read-softly-from-string (string)
+ "Returns three values:
+
+ 1. the object resulting from READing STRING.
+
+ 2. The index of the first character in STRING that was not read.
+
+ 3. T if the object is a symbol that had to be newly interned
+ in some package. (This does not work for symbols in
+ compound forms like lists or vectors.)"
+ (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string)
+ (if found?
+ (values symbol (length string) nil)
+ (multiple-value-bind (sexp pos) (read-from-string string)
+ (values sexp pos
+ (when (symbolp sexp)
+ (prog1 t
+ ;; assert that PARSE-SYMBOL didn't parse incorrectly.
+ (assert (and (equal symbol-name (symbol-name sexp))
+ (eq package (symbol-package sexp)))))))))))
+
+(defun unintern-in-home-package (symbol)
+ (unintern symbol (symbol-package symbol)))
+
+;; FIXME: deal with #\| etc. hard to do portably.
+(defun tokenize-symbol (string)
+ "STRING is interpreted as the string representation of a symbol
+and is tokenized accordingly. The result is returned in three
+values: The package identifier part, the actual symbol identifier
+part, and a flag if the STRING represents a symbol that is
+internal to the package identifier part. (Notice that the flag is
+also true with an empty package identifier part, as the STRING is
+considered to represent a symbol internal to some current package.)"
+ (let ((package (let ((pos (position #\: string)))
+ (if pos (subseq string 0 pos) nil)))
+ (symbol (let ((pos (position #\: string :from-end t)))
+ (if pos (subseq string (1+ pos)) string)))
+ (internp (not (= (count #\: string) 1))))
+ (values symbol package internp)))
+
+(defun tokenize-symbol-thoroughly (string)
+ "This version of TOKENIZE-SYMBOL handles escape characters."
+ (let ((package nil)
+ (token (make-array (length string) :element-type 'character
+ :fill-pointer 0))
+ (backslash nil)
+ (vertical nil)
+ (internp nil))
+ (loop for char across string
+ do (cond
+ (backslash
+ (vector-push-extend char token)
+ (setq backslash nil))
+ ((char= char #\\) ; Quotes next character, even within |...|
+ (setq backslash t))
+ ((char= char #\|)
+ (setq vertical t))
+ (vertical
+ (vector-push-extend char token))
+ ((char= char #\:)
+ (if package
+ (setq internp t)
+ (setq package token
+ token (make-array (length string)
+ :element-type 'character
+ :fill-pointer 0))))
+ (t
+ (vector-push-extend (casify-char char) token))))
+ (values token package (or (not package) internp))))
+
+(defun untokenize-symbol (package-name internal-p symbol-name)
+ "The inverse of TOKENIZE-SYMBOL.
+
+ (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
+ (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
+ (untokenize-symbol nil nil \"foo\") ==> \"foo\"
+"
+ (cond ((not package-name) symbol-name)
+ (internal-p (cat package-name "::" symbol-name))
+ (t (cat package-name ":" symbol-name))))
+
+(defun casify-char (char)
+ "Convert CHAR accoring to readtable-case."
+ (ecase (readtable-case *readtable*)
+ (:preserve char)
+ (:upcase (char-upcase char))
+ (:downcase (char-downcase char))
+ (:invert (if (upper-case-p char)
+ (char-downcase char)
+ (char-upcase char)))))
+
+(defun parse-symbol (string &optional (package *package*))
+ "Find the symbol named STRING.
+Return the symbol and a flag indicating whether the symbols was found."
+ (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
+ (let ((package (cond ((string= pname "") keyword-package)
+ (pname (find-package pname))
+ (t package))))
+ (if package
+ (multiple-value-bind (symbol flag) (find-symbol sname package)
+ (values symbol flag sname package))
+ (values nil nil nil nil)))))
+
+(defun parse-symbol-or-lose (string &optional (package *package*))
+ (multiple-value-bind (symbol status) (parse-symbol string package)
+ (if status
+ (values symbol status)
+ (error "Unknown symbol: ~A [in ~A]" string package))))
+
+(defun parse-package (string)
+ "Find the package named STRING.
+Return the package or nil."
+ ;; STRING comes usually from a (in-package STRING) form.
+ (ignore-errors
+ (find-package (let ((*package* *swank-io-package*))
+ (read-from-string string)))))
+
+(defun unparse-name (string)
+ "Print the name STRING according to the current printer settings."
+ ;; this is intended for package or symbol names
+ (subseq (prin1-to-string (make-symbol string)) 2))
+
+(defun guess-package (string)
+ "Guess which package corresponds to STRING.
+Return nil if no package matches."
+ (or (find-package string)
+ (parse-package string)
+ (if (find #\! string) ; for SBCL
+ (guess-package (substitute #\- #\! string)))))
+
+(defvar *readtable-alist* (default-readtable-alist)
+ "An alist mapping package names to readtables.")
+
+(defun guess-buffer-readtable (package-name)
+ (let ((package (guess-package package-name)))
+ (or (and package
+ (cdr (assoc (package-name package) *readtable-alist*
+ :test #'string=)))
+ *readtable*)))
+
+
+;;;; Evaluation
+
+(defvar *pending-continuations* '()
+ "List of continuations for Emacs. (thread local)")
+
+(defun guess-buffer-package (string)
+ "Return a package for STRING.
+Fall back to the the current if no such package exists."
+ (or (and string (guess-package string))
+ *package*))
+
+(defun eval-for-emacs (form buffer-package id)
+ "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
+Return the result to the continuation ID.
+Errors are trapped and invoke our debugger."
+ (call-with-debugger-hook
+ #'swank-debugger-hook
+ (lambda ()
+ (let (ok result)
+ (unwind-protect
+ (let ((*buffer-package* (guess-buffer-package buffer-package))
+ (*buffer-readtable* (guess-buffer-readtable buffer-package))
+ (*pending-continuations* (cons id *pending-continuations*)))
+ (check-type *buffer-package* package)
+ (check-type *buffer-readtable* readtable)
+ ;; APPLY would be cleaner than EVAL.
+ ;;(setq result (apply (car form) (cdr form)))
+ (setq result (eval form))
+ (run-hook *pre-reply-hook*)
+ (finish-output)
+ (setq ok t))
+ (force-user-output)
+ (send-to-emacs `(:return ,(current-thread)
+ ,(if ok
+ `(:ok ,result)
+ `(:abort))
+ ,id)))))))
+
+(defvar *echo-area-prefix* "=> "
+ "A prefix that `format-values-for-echo-area' should use.")
+
+(defun format-values-for-echo-area (values)
+ (with-buffer-syntax ()
+ (let ((*print-readably* nil))
+ (cond ((null values) "; No value")
+ ((and (length= values 1) (integerp (car values)))
+ (let ((i (car values)))
+ (format nil "~A~D (#x~X, #o~O, #b~B)"
+ *echo-area-prefix* i i i i)))
+ (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
+
+(defslimefun interactive-eval (string)
+ (with-buffer-syntax ()
+ (let ((values (multiple-value-list (eval (from-string string)))))
+ (fresh-line)
+ (finish-output)
+ (format-values-for-echo-area values))))
+
+(defslimefun eval-and-grab-output (string)
+ (with-buffer-syntax ()
+ (let* ((s (make-string-output-stream))
+ (*standard-output* s)
+ (values (multiple-value-list (eval (from-string string)))))
+ (list (get-output-stream-string s)
+ (format nil "~{~S~^~%~}" values)))))
+
+(defun eval-region (string)
+ "Evaluate STRING.
+Return the results of the last form as a list and as secondary value the
+last form."
+ (with-input-from-string (stream string)
+ (let (- values)
+ (loop
+ (let ((form (read stream nil stream)))
+ (when (eq form stream)
+ (return (values values -)))
+ (setq - form)
+ (setq values (multiple-value-list (eval form)))
+ (finish-output))))))
+
+(defslimefun interactive-eval-region (string)
+ (with-buffer-syntax ()
+ (format-values-for-echo-area (eval-region string))))
+
+(defslimefun re-evaluate-defvar (form)
+ (with-buffer-syntax ()
+ (let ((form (read-from-string form)))
+ (destructuring-bind (dv name &optional value doc) form
+ (declare (ignore value doc))
+ (assert (eq dv 'defvar))
+ (makunbound name)
+ (prin1-to-string (eval form))))))
+
+(defvar *swank-pprint-bindings*
+ `((*print-pretty* . t)
+ (*print-level* . nil)
+ (*print-length* . nil)
+ (*print-circle* . t)
+ (*print-gensym* . t)
+ (*print-readably* . nil))
+ "A list of variables bindings during pretty printing.
+Used by pprint-eval.")
+
+(defun swank-pprint (list)
+ "Bind some printer variables and pretty print each object in LIST."
+ (with-buffer-syntax ()
+ (with-bindings *swank-pprint-bindings*
+ (cond ((null list) "; No value")
+ (t (with-output-to-string (*standard-output*)
+ (dolist (o list)
+ (pprint o)
+ (terpri))))))))
+
+(defslimefun pprint-eval (string)
+ (with-buffer-syntax ()
+ (swank-pprint (multiple-value-list (eval (read-from-string string))))))
+
+(defslimefun set-package (name)
+ "Set *package* to the package named NAME.
+Return the full package-name and the string to use in the prompt."
+ (let ((p (guess-package name)))
+ (assert (packagep p))
+ (setq *package* p)
+ (list (package-name p) (package-string-for-prompt p))))
+
+;;;;; Listener eval
+
+(defvar *listener-eval-function* 'repl-eval)
+
+(defslimefun listener-eval (string)
+ (funcall *listener-eval-function* string))
+
+(defvar *send-repl-results-function* 'send-repl-results-to-emacs)
+
+(defun repl-eval (string)
+ (clear-user-input)
+ (with-buffer-syntax ()
+ (track-package
+ (lambda ()
+ (multiple-value-bind (values last-form) (eval-region string)
+ (setq *** ** ** * * (car values)
+ /// // // / / values
+ +++ ++ ++ + + last-form)
+ (funcall *send-repl-results-function* values)))))
+ nil)
+
+(defun track-package (fun)
+ (let ((p *package*))
+ (unwind-protect (funcall fun)
+ (unless (eq *package* p)
+ (send-to-emacs (list :new-package (package-name *package*)
+ (package-string-for-prompt *package*)))))))
+
+(defun send-repl-results-to-emacs (values)
+ (fresh-line)
+ (finish-output)
+ (if (null values)
+ (send-to-emacs `(:write-string "; No value" :repl-result))
+ (dolist (v values)
+ (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
+ :repl-result)))))
+
+(defun cat (&rest strings)
+ "Concatenate all arguments and make the result a string."
+ (with-output-to-string (out)
+ (dolist (s strings)
+ (etypecase s
+ (string (write-string s out))
+ (character (write-char s out))))))
+
+(defun package-string-for-prompt (package)
+ "Return the shortest nickname (or canonical name) of PACKAGE."
+ (unparse-name
+ (or (canonical-package-nickname package)
+ (auto-abbreviated-package-name package)
+ (shortest-package-nickname package))))
+
+(defun canonical-package-nickname (package)
+ "Return the canonical package nickname, if any, of PACKAGE."
+ (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
+ :test #'string=))))
+ (and name (string name))))
+
+(defun auto-abbreviated-package-name (package)
+ "Return an abbreviated 'name' for PACKAGE.
+
+N.B. this is not an actual package name or nickname."
+ (when *auto-abbreviate-dotted-packages*
+ (let ((last-dot (position #\. (package-name package) :from-end t)))
+ (when last-dot (subseq (package-name package) (1+ last-dot))))))
+
+(defun shortest-package-nickname (package)
+ "Return the shortest nickname (or canonical name) of PACKAGE."
+ (loop for name in (cons (package-name package) (package-nicknames package))
+ for shortest = name then (if (< (length name) (length shortest))
+ name
+ shortest)
+ finally (return shortest)))
+
+(defslimefun ed-in-emacs (&optional what)
+ "Edit WHAT in Emacs.
+
+WHAT can be:
+ A pathname or a string,
+ A list (PATHNAME-OR-STRING LINE [COLUMN]),
+ A function name (symbol or cons),
+ NIL.
+
+Returns true if it actually called emacs, or NIL if not."
+ (flet ((pathname-or-string-p (thing)
+ (or (pathnamep thing) (typep thing 'string))))
+ (let ((target
+ (cond ((and (listp what) (pathname-or-string-p (first what)))
+ (cons (canonicalize-filename (car what)) (cdr what)))
+ ((pathname-or-string-p what)
+ (canonicalize-filename what))
+ ((symbolp what) what)
+ ((consp what) what)
+ (t (return-from ed-in-emacs nil)))))
+ (cond
+ (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (send-oob-to-emacs `(:ed ,target))))
+ (t nil)))))
+
+(defslimefun inspect-in-emacs (what)
+ "Inspect WHAT in Emacs."
+ (flet ((send-it ()
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (send-oob-to-emacs `(:inspect ,(inspect-object what))))))
+ (cond
+ (*emacs-connection*
+ (send-it))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (send-it))))
+ what))
+
+(defslimefun value-for-editing (form)
+ "Return a readable value of FORM for editing in Emacs.
+FORM is expected, but not required, to be SETF'able."
+ ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
+ (with-buffer-syntax ()
+ (prin1-to-string (eval (read-from-string form)))))
+
+(defslimefun commit-edited-value (form value)
+ "Set the value of a setf'able FORM to VALUE.
+FORM and VALUE are both strings from Emacs."
+ (with-buffer-syntax ()
+ (eval `(setf ,(read-from-string form)
+ ,(read-from-string (concatenate 'string "`" value))))
+ t))
+
+(defun background-message (format-string &rest args)
+ "Display a message in Emacs' echo area.
+
+Use this function for informative messages only. The message may even
+be dropped, if we are too busy with other things."
+ (when *emacs-connection*
+ (send-to-emacs `(:background-message
+ ,(apply #'format nil format-string args)))))
+
+
+;;;; Debugger
+
+(defun swank-debugger-hook (condition hook)
+ "Debugger function for binding *DEBUGGER-HOOK*.
+Sends a message to Emacs declaring that the debugger has been entered,
+then waits to handle further requests from Emacs. Eventually returns
+after Emacs causes a restart to be invoked."
+ (declare (ignore hook))
+ (cond (*emacs-connection*
+ (debug-in-emacs condition))
+ ((default-connection)
+ (with-connection ((default-connection))
+ (debug-in-emacs condition)))))
+
+(defvar *global-debugger* t
+ "Non-nil means the Swank debugger hook will be installed globally.")
+
+(add-hook *new-connection-hook* 'install-debugger)
+(defun install-debugger (connection)
+ (declare (ignore connection))
+ (when *global-debugger*
+ (install-debugger-globally #'swank-debugger-hook)))
+
+;;;;; Debugger loop
+;;;
+;;; These variables are dynamically bound during debugging.
+;;;
+(defvar *swank-debugger-condition* nil
+ "The condition being debugged.")
+
+(defvar *sldb-level* 0
+ "The current level of recursive debugging.")
+
+(defvar *sldb-initial-frames* 20
+ "The initial number of backtrace frames to send to Emacs.")
+
+(defvar *sldb-restarts* nil
+ "The list of currenlty active restarts.")
+
+(defvar *sldb-stepping-p* nil
+ "True during execution of a step command.")
+
+(defun debug-in-emacs (condition)
+ (let ((*swank-debugger-condition* condition)
+ (*sldb-restarts* (compute-sane-restarts condition))
+ (*package* (or (and (boundp '*buffer-package*)
+ (symbol-value '*buffer-package*))
+ *package*))
+ (*sldb-level* (1+ *sldb-level*))
+ (*sldb-stepping-p* nil)
+ (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
+ (force-user-output)
+ (call-with-debugging-environment
+ (lambda ()
+ (with-bindings *sldb-printer-bindings*
+ (sldb-loop *sldb-level*))))))
+
+(defun sldb-loop (level)
+ (unwind-protect
+ (catch 'sldb-enter-default-debugger
+ (send-to-emacs
+ (list* :debug (current-thread) level
+ (debugger-info-for-emacs 0 *sldb-initial-frames*)))
+ (loop (catch 'sldb-loop-catcher
+ (with-simple-restart (abort "Return to sldb level ~D." level)
+ (send-to-emacs (list :debug-activate (current-thread)
+ level))
+ (handler-bind ((sldb-condition #'handle-sldb-condition))
+ (read-from-emacs))))))
+ (send-to-emacs `(:debug-return
+ ,(current-thread) ,level ,*sldb-stepping-p*))))
+
+(defun handle-sldb-condition (condition)
+ "Handle an internal debugger condition.
+Rather than recursively debug the debugger (a dangerous idea!), these
+conditions are simply reported."
+ (let ((real-condition (original-condition condition)))
+ (send-to-emacs `(:debug-condition ,(current-thread)
+ ,(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."
+ (let ((*print-pretty* t) (*print-right-margin* 65))
+ (handler-case
+ (format-sldb-condition 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*))
+ (condition-extras *swank-debugger-condition*)))
+
+(defun format-restarts-for-emacs ()
+ "Return a list of restarts for *swank-debugger-condition* in a
+format suitable for Emacs."
+ (let ((*print-right-margin* most-positive-fixnum))
+ (loop for restart in *sldb-restarts*
+ collect (list (princ-to-string (restart-name restart))
+ (princ-to-string restart)))))
+
+
+;;;;; SLDB entry points
+
+(defslimefun sldb-break-with-default-debugger ()
+ "Invoke the default debugger by returning from our debugger-loop."
+ (throw 'sldb-enter-default-debugger nil))
+
+(defslimefun backtrace (start end)
+ "Return a list ((I FRAME) ...) of frames from START to END.
+I is an integer describing and FRAME a string."
+ (loop for frame in (compute-backtrace start end)
+ for i from start
+ collect (list i (with-output-to-string (stream)
+ (handler-case
+ (with-bindings *backtrace-printer-bindings*
+ (print-frame frame stream))
+ (t ()
+ (format stream "[error printing frame]")))))))
+
+(defslimefun 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}*) (cont*))
+where
+ condition ::= (description type [extra])
+ restart ::= (name description)
+ stack-frame ::= (number description)
+ extra ::= (:references and other random things)
+ cont ::= continutation
+condition---a pair of strings: message, and type. If show-source is
+not nil it is a frame number for which the source should be displayed.
+
+restart---a pair of strings: restart name, and description.
+
+stack-frame---a number from zero (the top), and a printed
+representation of the frame's call.
+
+continutation---the id of a pending Emacs continuation.
+
+Below is an example return value. In this case the condition was a
+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]\")
+ ((\"ABORT\" \"Return to Slime toplevel.\")
+ (\"ABORT\" \"Return to Top-Level.\"))
+ ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
+ (4))"
+ (list (debugger-condition-for-emacs)
+ (format-restarts-for-emacs)
+ (backtrace start end)
+ *pending-continuations*))
+
+(defun nth-restart (index)
+ (nth index *sldb-restarts*))
+
+(defslimefun invoke-nth-restart (index)
+ (invoke-restart-interactively (nth-restart index)))
+
+(defslimefun sldb-abort ()
+ (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
+
+(defslimefun sldb-continue ()
+ (continue))
+
+(defslimefun throw-to-toplevel ()
+ "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
+If we are not evaluating an RPC then ABORT instead."
+ (let ((restart (find-restart *sldb-quit-restart*)))
+ (cond (restart (invoke-restart restart))
+ (t (format nil
+ "Restart not found: ~a"
+ *sldb-quit-restart*)))))
+
+(defslimefun invoke-nth-restart-for-emacs (sldb-level n)
+ "Invoke the Nth available restart.
+SLDB-LEVEL is the debug level when the request was made. If this
+has changed, ignore the request."
+ (when (= sldb-level *sldb-level*)
+ (invoke-nth-restart n)))
+
+(defun wrap-sldb-vars (form)
+ `(let ((*sldb-level* ,*sldb-level*))
+ ,form))
+
+(defslimefun eval-string-in-frame (string index)
+ (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
+ index)))
+
+(defslimefun pprint-eval-string-in-frame (string index)
+ (swank-pprint
+ (multiple-value-list
+ (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
+
+(defslimefun frame-locals-for-emacs (index)
+ "Return a property list ((&key NAME ID VALUE) ...) describing
+the local variables in the frame INDEX."
+ (with-bindings *backtrace-printer-bindings*
+ (mapcar (lambda (frame-locals)
+ (destructuring-bind (&key name id value) frame-locals
+ (list :name (prin1-to-string name) :id id
+ :value (to-string value))))
+ (frame-locals index))))
+
+(defslimefun frame-catch-tags-for-emacs (frame-index)
+ (mapcar #'to-string (frame-catch-tags frame-index)))
+
+(defslimefun sldb-disassemble (index)
+ (with-output-to-string (*standard-output*)
+ (disassemble-frame index)))
+
+(defslimefun sldb-return-from-frame (index string)
+ (let ((form (from-string string)))
+ (to-string (multiple-value-list (return-from-frame index form)))))
+
+(defslimefun sldb-break (name)
+ (with-buffer-syntax ()
+ (sldb-break-at-start (read-from-string name))))
+
+(defmacro define-stepper-function (name backend-function-name)
+ `(defslimefun ,name (frame)
+ (cond ((sldb-stepper-condition-p *swank-debugger-condition*)
+ (setq *sldb-stepping-p* t)
+ (,backend-function-name))
+ ((find-restart 'continue)
+ (activate-stepping frame)
+ (setq *sldb-stepping-p* t)
+ (continue))
+ (t
+ (error "Not currently single-stepping, and no continue restart available.")))))
+
+(define-stepper-function sldb-step sldb-step-into)
+(define-stepper-function sldb-next sldb-step-next)
+(define-stepper-function sldb-out sldb-step-out)
+
+
+;;;; Compilation Commands.
+
+(defvar *compiler-notes* '()
+ "List of compiler notes for the last compilation unit.")
+
+(defun clear-compiler-notes ()
+ (setf *compiler-notes* '()))
+
+(defun canonicalize-filename (filename)
+ (namestring (truename filename)))
+
+(defslimefun compiler-notes-for-emacs ()
+ "Return the list of compiler notes for the last compilation unit."
+ (reverse *compiler-notes*))
+
+(defun measure-time-interval (fn)
+ "Call FN and return the first return value and the elapsed time.
+The time is measured in microseconds."
+ (declare (type function fn))
+ (let ((before (get-internal-real-time)))
+ (values
+ (funcall fn)
+ (* (- (get-internal-real-time) before)
+ (/ 1000000 internal-time-units-per-second)))))
+
+(defun record-note-for-condition (condition)
+ "Record a note for a compiler-condition."
+ (push (make-compiler-note condition) *compiler-notes*))
+
+(defun make-compiler-note (condition)
+ "Make a compiler note data structure from a compiler-condition."
+ (declare (type compiler-condition condition))
+ (list* :message (message condition)
+ :severity (severity condition)
+ :location (location condition)
+ :references (references condition)
+ (let ((s (short-message condition)))
+ (if s (list :short-message s)))))
+
+(defun swank-compiler (function)
+ (clear-compiler-notes)
+ (multiple-value-bind (result usecs)
+ (with-simple-restart (abort "Abort SLIME compilation.")
+ (handler-bind ((compiler-condition #'record-note-for-condition))
+ (measure-time-interval function)))
+ ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked;
+ ;; unfortunately the SWANK protocol doesn't support returning multiple
+ ;; values, so we gotta convert it explicitely to a list in either case.
+ (if (and (not result) (eq usecs 't))
+ (list nil nil)
+ (list (to-string result)
+ (format nil "~,2F" (/ usecs 1000000.0))))))
+
+(defslimefun compile-file-for-emacs (filename load-p)
+ "Compile FILENAME and, when LOAD-P, load the result.
+Record compiler notes signalled as `compiler-condition's."
+ (with-buffer-syntax ()
+ (let ((*compile-print* nil))
+ (swank-compiler
+ (lambda ()
+ (swank-compile-file filename load-p
+ (or (guess-external-format filename)
+ :default)))))))
+
+(defslimefun compile-string-for-emacs (string buffer position directory)
+ "Compile STRING (exerpted from BUFFER at POSITION).
+Record compiler notes signalled as `compiler-condition's."
+ (with-buffer-syntax ()
+ (swank-compiler
+ (lambda ()
+ (let ((*compile-print* nil) (*compile-verbose* t))
+ (swank-compile-string string :buffer buffer :position position
+ :directory directory))))))
+
+(defun file-newer-p (new-file old-file)
+ "Returns true if NEW-FILE is newer than OLD-FILE."
+ (> (file-write-date new-file) (file-write-date old-file)))
+
+(defun requires-compile-p (source-file)
+ (let ((fasl-file (probe-file (compile-file-pathname source-file))))
+ (or (not fasl-file)
+ (file-newer-p source-file fasl-file))))
+
+(defslimefun compile-file-if-needed (filename loadp)
+ (cond ((requires-compile-p filename)
+ (compile-file-for-emacs filename loadp))
+ (loadp
+ (load (compile-file-pathname filename))
+ nil)))
+
+
+;;;; Loading
+
+(defslimefun load-file (filename)
+ (to-string (load filename)))
+
+(defslimefun load-file-set-package (filename &optional package)
+ (load-file filename)
+ (if package
+ (set-package package)))
+
+
+;;;;; swank-require
+
+(defslimefun swank-require (modules &optional filename)
+ "Load the module MODULE."
+ (dolist (module (if (listp modules) modules (list modules)))
+ (unless (member (string module) *modules* :test #'string=)
+ (require module (or filename (module-filename module)))))
+ *modules*)
+
+(defvar *find-module* 'find-module
+ "Pluggable function to locate modules.
+The function receives a module name as argument and should return
+the filename of the module (or nil if the file doesn't exist).")
+
+(defun module-filename (module)
+ "Return the filename for the module MODULE."
+ (or (funcall *find-module* module)
+ (error "Can't locate module: ~s" module)))
+
+;;;;;; Simple *find-module* function.
+
+(defun merged-directory (dirname defaults)
+ (pathname-directory
+ (merge-pathnames
+ (make-pathname :directory `(:relative ,dirname) :defaults defaults)
+ defaults)))
+
+(defvar *load-path*
+ (list (make-pathname :directory (merged-directory "contrib" *load-truename*)
+ :name nil :type nil :version nil
+ :defaults *load-truename*))
+ "A list of directories to search for modules.")
+
+(defun module-canditates (name dir)
+ (list (compile-file-pathname (make-pathname :name name :defaults dir))
+ (make-pathname :name name :type "lisp" :defaults dir)))
+
+(defun find-module (module)
+ (let ((name (string-downcase module)))
+ (some (lambda (dir) (some #'probe-file (module-canditates name dir)))
+ *load-path*)))
+
+
+;;;; Macroexpansion
+
+(defvar *macroexpand-printer-bindings*
+ '((*print-circle* . nil)
+ (*print-pretty* . t)
+ (*print-escape* . t)
+ (*print-lines* . nil)
+ (*print-level* . nil)
+ (*print-length* . nil)))
+
+(defun apply-macro-expander (expander string)
+ (with-buffer-syntax ()
+ (with-bindings *macroexpand-printer-bindings*
+ (prin1-to-string (funcall expander (from-string string))))))
+
+(defslimefun swank-macroexpand-1 (string)
+ (apply-macro-expander #'macroexpand-1 string))
+
+(defslimefun swank-macroexpand (string)
+ (apply-macro-expander #'macroexpand string))
+
+(defslimefun swank-macroexpand-all (string)
+ (apply-macro-expander #'macroexpand-all string))
+
+(defslimefun swank-compiler-macroexpand-1 (string)
+ (apply-macro-expander #'compiler-macroexpand-1 string))
+
+(defslimefun swank-compiler-macroexpand (string)
+ (apply-macro-expander #'compiler-macroexpand string))
+
+(defslimefun disassemble-symbol (name)
+ (with-buffer-syntax ()
+ (with-output-to-string (*standard-output*)
+ (let ((*print-readably* nil))
+ (disassemble (fdefinition (from-string name)))))))
+
+
+;;;; Simple completion
+
+(defslimefun simple-completions (string package)
+ "Return a list of completions for the string STRING."
+ (let ((strings (all-completions string package #'prefix-match-p)))
+ (list strings (longest-common-prefix strings))))
+
+(defun all-completions (string package test)
+ (multiple-value-bind (name pname intern) (tokenize-symbol string)
+ (let* ((extern (and pname (not intern)))
+ (pack (cond ((equal pname "") keyword-package)
+ ((not pname) (guess-buffer-package package))
+ (t (guess-package pname))))
+ (test (lambda (sym) (funcall test name (unparse-symbol sym))))
+ (syms (and pack (matching-symbols pack extern test))))
+ (format-completion-set (mapcar #'unparse-symbol syms) intern pname))))
+
+(defun matching-symbols (package external test)
+ (let ((test (if external
+ (lambda (s)
+ (and (symbol-external-p s package)
+ (funcall test s)))
+ test))
+ (result '()))
+ (do-symbols (s package)
+ (when (funcall test s)
+ (push s result)))
+ (remove-duplicates result)))
+
+(defun unparse-symbol (symbol)
+ (let ((*print-case* (case (readtable-case *readtable*)
+ (:downcase :upcase)
+ (t :downcase))))
+ (unparse-name (symbol-name symbol))))
+
+(defun prefix-match-p (prefix string)
+ "Return true if PREFIX is a prefix of STRING."
+ (not (mismatch prefix string :end2 (min (length string) (length prefix)))))
+
+(defun longest-common-prefix (strings)
+ "Return the longest string that is a common prefix of STRINGS."
+ (if (null strings)
+ ""
+ (flet ((common-prefix (s1 s2)
+ (let ((diff-pos (mismatch s1 s2)))
+ (if diff-pos (subseq s1 0 diff-pos) s1))))
+ (reduce #'common-prefix strings))))
+
+(defun format-completion-set (strings internal-p package-name)
+ "Format a set of completion strings.
+Returns a list of completions with package qualifiers if needed."
+ (mapcar (lambda (string) (untokenize-symbol package-name internal-p string))
+ (sort strings #'string<)))
+
+
+;;;; Simple arglist display
+
+(defslimefun operator-arglist (name package)
+ (ignore-errors
+ (let ((args (arglist (parse-symbol name (guess-buffer-package package))))
+ (*print-escape* nil))
+ (cond ((eq args :not-available) nil)
+ (t (format nil "(~a ~/pprint-fill/)" name args))))))
+
+
+;;;; Documentation
+
+(defslimefun apropos-list-for-emacs (name &optional external-only
+ case-sensitive package)
+ "Make an apropos search for Emacs.
+The result is a list of property lists."
+ (let ((package (if package
+ (or (parse-package package)
+ (error "No such package: ~S" package)))))
+ ;; The MAPCAN will filter all uninteresting symbols, i.e. those
+ ;; who cannot be meaningfully described.
+ (mapcan (listify #'briefly-describe-symbol-for-emacs)
+ (sort (remove-duplicates
+ (apropos-symbols name external-only case-sensitive package))
+ #'present-symbol-before-p))))
+
+(defun briefly-describe-symbol-for-emacs (symbol)
+ "Return a property list describing SYMBOL.
+Like `describe-symbol-for-emacs' but with at most one line per item."
+ (flet ((first-line (string)
+ (let ((pos (position #\newline string)))
+ (if (null pos) string (subseq string 0 pos)))))
+ (let ((desc (map-if #'stringp #'first-line
+ (describe-symbol-for-emacs symbol))))
+ (if desc
+ (list* :designator (to-string symbol) desc)))))
+
+(defun map-if (test fn &rest lists)
+ "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST.
+Example:
+\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)"
+ (apply #'mapcar
+ (lambda (x) (if (funcall test x) (funcall fn x) x))
+ lists))
+
+(defun listify (f)
+ "Return a function like F, but which returns any non-null value
+wrapped in a list."
+ (lambda (x)
+ (let ((y (funcall f x)))
+ (and y (list y)))))
+
+(defun present-symbol-before-p (x y)
+ "Return true if X belongs before Y in a printed summary of symbols.
+Sorted alphabetically by package name and then symbol name, except
+that symbols accessible in the current package go first."
+ (declare (type symbol x y))
+ (flet ((accessible (s)
+ ;; Test breaks on NIL for package that does not inherit it
+ (eq (find-symbol (symbol-name s) *buffer-package*) s)))
+ (let ((ax (accessible x)) (ay (accessible y)))
+ (cond ((and ax ay) (string< (symbol-name x) (symbol-name y)))
+ (ax t)
+ (ay nil)
+ (t (let ((px (symbol-package x)) (py (symbol-package y)))
+ (if (eq px py)
+ (string< (symbol-name x) (symbol-name y))
+ (string< (package-name px) (package-name py)))))))))
+
+(defun make-apropos-matcher (pattern case-sensitive)
+ (let ((chr= (if case-sensitive #'char= #'char-equal)))
+ (lambda (symbol)
+ (search pattern (string symbol) :test chr=))))
+
+(defun apropos-symbols (string external-only case-sensitive package)
+ (let ((packages (or package (remove (find-package :keyword)
+ (list-all-packages))))
+ (matcher (make-apropos-matcher string case-sensitive))
+ (result))
+ (with-package-iterator (next packages :external :internal)
+ (loop (multiple-value-bind (morep symbol) (next)
+ (cond ((not morep) (return))
+ ((and (if external-only (symbol-external-p symbol) t)
+ (funcall matcher symbol))
+ (push symbol result))))))
+ result))
+
+(defun call-with-describe-settings (fn)
+ (let ((*print-readably* nil))
+ (funcall fn)))
+
+(defmacro with-describe-settings ((&rest _) &body body)
+ (declare (ignore _))
+ `(call-with-describe-settings (lambda () ,@body)))
+
+(defun describe-to-string (object)
+ (with-describe-settings ()
+ (with-output-to-string (*standard-output*)
+ (describe object))))
+
+(defslimefun describe-symbol (symbol-name)
+ (with-buffer-syntax ()
+ (describe-to-string (parse-symbol-or-lose symbol-name))))
+
+(defslimefun describe-function (name)
+ (with-buffer-syntax ()
+ (let ((symbol (parse-symbol-or-lose name)))
+ (describe-to-string (or (macro-function symbol)
+ (symbol-function symbol))))))
+
+(defslimefun describe-definition-for-emacs (name kind)
+ (with-buffer-syntax ()
+ (with-describe-settings ()
+ (with-output-to-string (*standard-output*)
+ (describe-definition (parse-symbol-or-lose name) kind)))))
+
+(defslimefun documentation-symbol (symbol-name &optional default)
+ (with-buffer-syntax ()
+ (multiple-value-bind (sym foundp) (parse-symbol symbol-name)
+ (if foundp
+ (let ((vdoc (documentation sym 'variable))
+ (fdoc (documentation sym 'function)))
+ (or (and (or vdoc fdoc)
+ (concatenate 'string
+ fdoc
+ (and vdoc fdoc '(#\Newline #\Newline))
+ vdoc))
+ default))
+ default))))
+
+
+;;;; Package Commands
+
+(defslimefun list-all-package-names (&optional nicknames)
+ "Return a list of all package names.
+Include the nicknames if NICKNAMES is true."
+ (mapcar #'unparse-name
+ (if nicknames
+ (mapcan #'package-names (list-all-packages))
+ (mapcar #'package-name (list-all-packages)))))
+
+
+;;;; Tracing
+
+;; Use eval for the sake of portability...
+(defun tracedp (fspec)
+ (member fspec (eval '(trace))))
+
+(defslimefun swank-toggle-trace (spec-string)
+ (let ((spec (from-string spec-string)))
+ (cond ((consp spec) ; handle complicated cases in the backend
+ (toggle-trace spec))
+ ((tracedp spec)
+ (eval `(untrace ,spec))
+ (format nil "~S is now untraced." spec))
+ (t
+ (eval `(trace ,spec))
+ (format nil "~S is now traced." spec)))))
+
+(defslimefun untrace-all ()
+ (untrace))
+
+(defslimefun redirect-trace-output (target)
+ (setf (connection.trace-output *emacs-connection*)
+ (make-output-stream-for-target *emacs-connection* target))
+ nil)
+
+
+;;;; Undefing
+
+(defslimefun undefine-function (fname-string)
+ (let ((fname (from-string fname-string)))
+ (format nil "~S" (fmakunbound fname))))
+
+
+;;;; Profiling
+
+(defun profiledp (fspec)
+ (member fspec (profiled-functions)))
+
+(defslimefun toggle-profile-fdefinition (fname-string)
+ (let ((fname (from-string fname-string)))
+ (cond ((profiledp fname)
+ (unprofile fname)
+ (format nil "~S is now unprofiled." fname))
+ (t
+ (profile fname)
+ (format nil "~S is now profiled." fname)))))
+
+
+;;;; Source Locations
+
+(defslimefun find-definitions-for-emacs (name)
+ "Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
+DSPEC is a string and LOCATION a source location. NAME is a string."
+ (multiple-value-bind (sexp error)
+ (ignore-errors (values (from-string name)))
+ (unless error
+ (loop for (dspec loc) in (find-definitions sexp)
+ collect (list (to-string dspec) loc)))))
+
+(defun alistify (list key test)
+ "Partition the elements of LIST into an alist. KEY extracts the key
+from an element and TEST is used to compare keys."
+ (declare (type function key))
+ (let ((alist '()))
+ (dolist (e list)
+ (let* ((k (funcall key e))
+ (probe (assoc k alist :test test)))
+ (if probe
+ (push e (cdr probe))
+ (push (cons k (list e)) alist))))
+ alist))
+
+(defun location-position< (pos1 pos2)
+ (cond ((and (position-p pos1) (position-p pos2))
+ (< (position-pos pos1)
+ (position-pos pos2)))
+ (t nil)))
+
+(defun partition (list test key)
+ (declare (type function test key))
+ (loop for e in list
+ if (funcall test (funcall key e)) collect e into yes
+ else collect e into no
+ finally (return (values yes no))))
+
+(defstruct (xref (:conc-name xref.)
+ (:type list))
+ dspec location)
+
+(defun location-valid-p (location)
+ (eq (car location) :location))
+
+(defun xref-buffer (xref)
+ (location-buffer (xref.location xref)))
+
+(defun xref-position (xref)
+ (location-buffer (xref.location xref)))
+
+(defun group-xrefs (xrefs)
+ "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
+The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
+ (multiple-value-bind (resolved errors)
+ (partition xrefs #'location-valid-p #'xref.location)
+ (let ((alist (alistify resolved #'xref-buffer #'equal)))
+ (append
+ (loop for (buffer . list) in alist
+ collect (cons (second buffer)
+ (mapcar (lambda (xref)
+ (cons (to-string (xref.dspec xref))
+ (xref.location xref)))
+ (sort list #'location-position<
+ :key #'xref-position))))
+ (if errors
+ (list (cons "Unresolved"
+ (mapcar (lambda (xref)
+ (cons (to-string (xref.dspec xref))
+ (xref.location xref)))
+ errors))))))))
+
+(defslimefun xref (type symbol-name)
+ (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))
+ (group-xrefs
+ (ecase type
+ (:calls (who-calls symbol))
+ (:calls-who (calls-who symbol))
+ (:references (who-references symbol))
+ (:binds (who-binds symbol))
+ (:sets (who-sets symbol))
+ (:macroexpands (who-macroexpands symbol))
+ (:specializes (who-specializes symbol))
+ (:callers (list-callers symbol))
+ (:callees (list-callees symbol))))))
+
+
+;;;; Inspecting
+
+(defun common-seperated-spec (list &optional (callback (lambda (v)
+ `(:value ,v))))
+ (butlast
+ (loop
+ for i in list
+ collect (funcall callback i)
+ collect ", ")))
+
+(defun inspector-princ (list)
+ "Like princ-to-string, but don't rewrite (function foo) as #'foo.
+Do NOT pass circular lists to this function."
+ (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
+ (set-pprint-dispatch '(cons (member function)) nil)
+ (princ-to-string list)))
+
+(defmethod inspect-for-emacs ((object cons) inspector)
+ (declare (ignore inspector))
+ (if (consp (cdr object))
+ (inspect-for-emacs-list object)
+ (inspect-for-emacs-simple-cons object)))
+
+(defun inspect-for-emacs-simple-cons (cons)
+ (values "A cons cell."
+ (label-value-line*
+ ('car (car cons))
+ ('cdr (cdr cons)))))
+
+(defun inspect-for-emacs-list (list)
+ (let ((maxlen 40))
+ (multiple-value-bind (length tail) (safe-length list)
+ (flet ((frob (title list)
+ (let (lines)
+ (loop for i from 0 for rest on list do
+ (if (consp (cdr rest)) ; e.g. (A . (B . ...))
+ (push (label-value-line i (car rest)) lines)
+ (progn ; e.g. (A . NIL) or (A . B)
+ (push (label-value-line i (car rest) :newline nil) lines)
+ (when (cdr rest)
+ (push '((:newline)) lines)
+ (push (label-value-line ':tail () :newline nil) lines))
+ (loop-finish)))
+ finally
+ (setf lines (reduce #'append (nreverse lines) :from-end t)))
+ (values title (append '("Elements:" (:newline)) lines)))))
+
+ (cond ((not length) ; circular
+ (frob "A circular list."
+ (cons (car list)
+ (ldiff (cdr list) list))))
+ ((and (<= length maxlen) (not tail))
+ (frob "A proper list." list))
+ (tail
+ (frob "An improper list." list))
+ (t
+ (frob "A proper list." list)))))))
+
+;; (inspect-for-emacs-list '#1=(a #1# . #1# ))
+
+(defun safe-length (list)
+ "Similar to `list-length', but avoid errors on improper lists.
+Return two values: the length of the list and the last cdr.
+NIL is returned if the list is circular."
+ (do ((n 0 (+ n 2)) ;Counter.
+ (fast list (cddr fast)) ;Fast pointer: leaps by 2.
+ (slow list (cdr slow))) ;Slow pointer: leaps by 1.
+ (nil)
+ (cond ((null fast) (return (values n nil)))
+ ((not (consp fast)) (return (values n fast)))
+ ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
+ ((and (eq fast slow) (> n 0)) (return nil))
+ ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
+
+(defvar *slime-inspect-contents-limit* nil "How many elements of
+ a hash table or array to show by default. If table has more than
+ this then offer actions to view more. Set to nil for no limit." )
+
+(defmethod inspect-for-emacs ((ht hash-table) inspector)
+ (declare (ignore inspector))
+ (values (prin1-to-string ht)
+ (append
+ (label-value-line*
+ ("Count" (hash-table-count ht))
+ ("Size" (hash-table-size ht))
+ ("Test" (hash-table-test ht))
+ ("Rehash size" (hash-table-rehash-size ht))
+ ("Rehash threshold" (hash-table-rehash-threshold ht)))
+ (let ((weakness (hash-table-weakness ht)))
+ (when weakness
+ `("Weakness: " (:value ,weakness) (:newline))))
+ (unless (zerop (hash-table-count ht))
+ `((:action "[clear hashtable]" ,(lambda () (clrhash ht))) (:newline)
+ "Contents: " (:newline)))
+ (if (and *slime-inspect-contents-limit*
+ (>= (hash-table-count ht) *slime-inspect-contents-limit*))
+ (inspect-bigger-piece-actions ht (hash-table-count ht))
+ nil)
+ (loop for key being the hash-keys of ht
+ for value being the hash-values of ht
+ repeat (or *slime-inspect-contents-limit* most-positive-fixnum)
+ append `((:value ,key) " = " (:value ,value)
+ " " (:action "[remove entry]"
+ ,(let ((key key))
+ (lambda () (remhash key ht))))
+ (:newline))))))
+
+(defun inspect-bigger-piece-actions (thing size)
+ (append
+ (if (> size *slime-inspect-contents-limit*)
+ (list (inspect-show-more-action thing)
+ '(:newline))
+ nil)
+ (list (inspect-whole-thing-action thing size)
+ '(:newline))))
+
+(defun inspect-whole-thing-action (thing size)
+ `(:action ,(format nil "Inspect all ~a elements."
+ size)
+ ,(lambda()
+ (let ((*slime-inspect-contents-limit* nil))
+ (swank::inspect-object thing)))))
+
+(defun inspect-show-more-action (thing)
+ `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..."
+ *slime-inspect-contents-limit* )
+ ,(lambda()
+ (let ((*slime-inspect-contents-limit*
+ (progn (format t "How many elements should be shown? ") (read))))
+ (swank::inspect-object thing)))))
+
+(defmethod inspect-for-emacs ((array array) inspector)
+ (declare (ignore inspector))
+ (values "An array."
+ (append
+ (label-value-line*
+ ("Dimensions" (array-dimensions array))
+ ("Its element type is" (array-element-type array))
+ ("Total size" (array-total-size array))
+ ("Adjustable" (adjustable-array-p array)))
+ (when (array-has-fill-pointer-p array)
+ (label-value-line "Fill pointer" (fill-pointer array)))
+ '("Contents:" (:newline))
+ (if (and *slime-inspect-contents-limit*
+ (>= (array-total-size array) *slime-inspect-contents-limit*))
+ (inspect-bigger-piece-actions array (length array))
+ nil)
+ (loop for i below (or *slime-inspect-contents-limit* (array-total-size array))
+ append (label-value-line i (row-major-aref array i))))))
+
+(defmethod inspect-for-emacs ((char character) inspector)
+ (declare (ignore inspector))
+ (values "A character."
+ (append
+ (label-value-line*
+ ("Char code" (char-code char))
+ ("Lower cased" (char-downcase char))
+ ("Upper cased" (char-upcase char)))
+ (if (get-macro-character char)
+ `("In the current readtable ("
+ (:value ,*readtable*) ") it is a macro character: "
+ (:value ,(get-macro-character char)))))))
+
+(defvar *inspectee*)
+(defvar *inspectee-parts*)
+(defvar *inspectee-actions*)
+(defvar *inspector-stack* '())
+(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
+(declaim (type vector *inspector-history*))
+(defvar *inspect-length* 30)
+(defvar *default-inspector* (make-default-inspector))
+
+(defun reset-inspector ()
+ (setq *inspectee* nil
+ *inspector-stack* nil
+ *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
+ *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
+ *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
+
+(defun valid-function-name-p (form)
+ (or (symbolp form)
+ (and (consp form)
+ (second form)
+ (not (third form))
+ (eq (first form) 'setf)
+ (symbolp (second form)))))
+
+(defslimefun init-inspector (string)
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object (eval (read-from-string string)))))
+
+(defun print-part-to-string (value)
+ (let ((string (to-string value))
+ (pos (position value *inspector-history*)))
+ (if pos
+ (format nil "#~D=~A" pos string)
+ string)))
+
+(defun inspector-content-for-emacs (specs)
+ (loop for part in specs collect
+ (etypecase part
+ (null ; XXX encourages sloppy programming
+ nil)
+ (string part)
+ (cons (destructure-case part
+ ((:newline)
+ (string #\newline))
+ ((:value obj &optional str)
+ (value-part-for-emacs obj str))
+ ((:action label lambda &key (refreshp t))
+ (action-part-for-emacs label lambda refreshp)))))))
+
+(defun assign-index (object vector)
+ (let ((index (fill-pointer vector)))
+ (vector-push-extend object vector)
+ index))
+
+(defun value-part-for-emacs (object string)
+ (list :value
+ (or string (print-part-to-string object))
+ (assign-index object *inspectee-parts*)))
+
+(defun action-part-for-emacs (label lambda refreshp)
+ (list :action label (assign-index (list lambda refreshp)
+ *inspectee-actions*)))
+
+(defun inspect-object (object &optional (inspector *default-inspector*))
+ (push (setq *inspectee* object) *inspector-stack*)
+ (unless (find object *inspector-history*)
+ (vector-push-extend object *inspector-history*))
+ (let ((*print-pretty* nil) ; print everything in the same line
+ (*print-circle* t)
+ (*print-readably* nil))
+ (multiple-value-bind (_ content) (inspect-for-emacs object inspector)
+ (declare (ignore _))
+ (list :title (with-output-to-string (s)
+ (print-unreadable-object (object s :type t :identity t)))
+ :id (assign-index object *inspectee-parts*)
+ :content (inspector-content-for-emacs content)))))
+
+(defslimefun inspector-nth-part (index)
+ (aref *inspectee-parts* index))
+
+(defslimefun inspect-nth-part (index)
+ (with-buffer-syntax ()
+ (inspect-object (inspector-nth-part index))))
+
+(defslimefun inspector-call-nth-action (index &rest args)
+ (destructuring-bind (action-lambda refreshp)
+ (aref *inspectee-actions* index)
+ (apply action-lambda args)
+ (if refreshp
+ (inspect-object (pop *inspector-stack*))
+ ;; tell emacs that we don't want to refresh the inspector buffer
+ nil)))
+
+(defslimefun inspector-pop ()
+ "Drop the inspector stack and inspect the second element. Return
+nil if there's no second element."
+ (with-buffer-syntax ()
+ (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*."
+ (with-buffer-syntax ()
+ (let ((position (position *inspectee* *inspector-history*)))
+ (cond ((= (1+ position) (length *inspector-history*))
+ nil)
+ (t (inspect-object (aref *inspector-history* (1+ position))))))))
+
+(defslimefun inspector-reinspect ()
+ (inspect-object *inspectee*))
+
+(defslimefun quit-inspector ()
+ (reset-inspector)
+ nil)
+
+(defslimefun describe-inspectee ()
+ "Describe the currently inspected object."
+ (with-buffer-syntax ()
+ (describe-to-string *inspectee*)))
+
+(defslimefun pprint-inspector-part (index)
+ "Pretty-print the currently inspected object."
+ (with-buffer-syntax ()
+ (swank-pprint (list (inspector-nth-part index)))))
+
+(defslimefun inspect-in-frame (string index)
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object (eval-in-frame (from-string string) index))))
+
+(defslimefun inspect-current-condition ()
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object *swank-debugger-condition*)))
+
+(defslimefun inspect-frame-var (frame var)
+ (with-buffer-syntax ()
+ (reset-inspector)
+ (inspect-object (frame-var-value frame var))))
+
+
+;;;; Thread listing
+
+(defvar *thread-list* ()
+ "List of threads displayed in Emacs. We don't care a about
+synchronization issues (yet). There can only be one thread listing at
+a time.")
+
+(defslimefun list-threads ()
+ "Return a list ((NAME DESCRIPTION) ...) of all threads."
+ (setq *thread-list* (all-threads))
+ (loop for thread in *thread-list*
+ for name = (thread-name thread)
+ collect (list (if (symbolp name) (symbol-name name) name)
+ (thread-status thread)
+ (thread-id thread))))
+
+(defslimefun quit-thread-browser ()
+ (setq *thread-list* nil))
+
+(defun nth-thread (index)
+ (nth index *thread-list*))
+
+(defslimefun debug-nth-thread (index)
+ (let ((connection *emacs-connection*))
+ (interrupt-thread (nth-thread index)
+ (lambda ()
+ (with-connection (connection)
+ (simple-break))))))
+
+(defslimefun kill-nth-thread (index)
+ (kill-thread (nth-thread index)))
+
+(defslimefun start-swank-server-in-thread (index port-file-name)
+ "Interrupt the INDEXth thread and make it start a swank server.
+The server port is written to PORT-FILE-NAME."
+ (interrupt-thread (nth-thread index)
+ (lambda ()
+ (start-server port-file-name :style nil))))
+
+;;;; Class browser
+
+(defun mop-helper (class-name fn)
+ (let ((class (find-class class-name nil)))
+ (if class
+ (mapcar (lambda (x) (to-string (class-name x)))
+ (funcall fn class)))))
+
+(defslimefun mop (type symbol-name)
+ "Return info about classes using mop.
+
+ When type is:
+ :subclasses - return the list of subclasses of class.
+ :superclasses - return the list of superclasses of class."
+ (let ((symbol (parse-symbol symbol-name *buffer-package*)))
+ (ecase type
+ (:subclasses
+ (mop-helper symbol #'swank-mop:class-direct-subclasses))
+ (:superclasses
+ (mop-helper symbol #'swank-mop:class-direct-superclasses)))))
+
+
+;;;; Automatically synchronized state
+;;;
+;;; Here we add hooks to push updates of relevant information to
+;;; Emacs.
+
+;;;;; *FEATURES*
+
+(defun sync-features-to-emacs ()
+ "Update Emacs if any relevant Lisp state has changed."
+ ;; FIXME: *slime-features* should be connection-local
+ (unless (eq *slime-features* *features*)
+ (setq *slime-features* *features*)
+ (send-to-emacs (list :new-features (features-for-emacs)))))
+
+(defun features-for-emacs ()
+ "Return `*slime-features*' in a format suitable to send it to Emacs."
+ *slime-features*)
+
+(add-hook *pre-reply-hook* 'sync-features-to-emacs)
+
+
+;;;;; Indentation of macros
+;;;
+;;; This code decides how macros should be indented (based on their
+;;; arglists) and tells Emacs. A per-connection cache is used to avoid
+;;; sending redundant information to Emacs -- we just say what's
+;;; changed since last time.
+;;;
+;;; The strategy is to scan all symbols, pick out the macros, and look
+;;; for &body-arguments.
+
+(defvar *configure-emacs-indentation* t
+ "When true, automatically send indentation information to Emacs
+after each command.")
+
+(defslimefun update-indentation-information ()
+ (perform-indentation-update *emacs-connection* t)
+ nil)
+
+;; This function is for *PRE-REPLY-HOOK*.
+(defun sync-indentation-to-emacs ()
+ "Send any indentation updates to Emacs via CONNECTION."
+ (when *configure-emacs-indentation*
+ (let ((fullp (need-full-indentation-update-p *emacs-connection*)))
+ (perform-indentation-update *emacs-connection* fullp))))
+
+(defun need-full-indentation-update-p (connection)
+ "Return true if the whole indentation cache should be updated.
+This is a heuristic to avoid scanning all symbols all the time:
+instead, we only do a full scan if the set of packages has changed."
+ (set-difference (list-all-packages)
+ (connection.indentation-cache-packages connection)))
+
+(defun perform-indentation-update (connection force)
+ "Update the indentation cache in CONNECTION and update Emacs.
+If FORCE is true then start again without considering the old cache."
+ (let ((cache (connection.indentation-cache connection)))
+ (when force (clrhash cache))
+ (let ((delta (update-indentation/delta-for-emacs cache force)))
+ (setf (connection.indentation-cache-packages connection)
+ (list-all-packages))
+ (unless (null delta)
+ (send-to-emacs (list :indentation-update delta))))))
+
+(defun update-indentation/delta-for-emacs (cache &optional force)
+ "Update the cache and return the changes in a (SYMBOL . INDENT) list.
+If FORCE is true then check all symbols, otherwise only check symbols
+belonging to the buffer package."
+ (let ((alist '()))
+ (flet ((consider (symbol)
+ (let ((indent (symbol-indentation symbol)))
+ (when indent
+ (unless (equal (gethash symbol cache) indent)
+ (setf (gethash symbol cache) indent)
+ (push (cons (string-downcase symbol) indent) alist))))))
+ (if force
+ (do-all-symbols (symbol)
+ (consider symbol))
+ (do-symbols (symbol *buffer-package*)
+ ;; We're really just interested in the symbols of *BUFFER-PACKAGE*,
+ ;; and *not* all symbols that are _present_ (cf. SYMBOL-STATUS.)
+ (when (eq (symbol-package symbol) *buffer-package*)
+ (consider symbol)))))
+ alist))
+
+(defun package-names (package)
+ "Return the name and all nicknames of PACKAGE in a fresh list."
+ (cons (package-name package) (copy-list (package-nicknames package))))
+
+(defun cl-symbol-p (symbol)
+ "Is SYMBOL a symbol in the COMMON-LISP package?"
+ (eq (symbol-package symbol) cl-package))
+
+(defun known-to-emacs-p (symbol)
+ "Return true if Emacs has special rules for indenting SYMBOL."
+ (cl-symbol-p symbol))
+
+(defun symbol-indentation (symbol)
+ "Return a form describing the indentation of SYMBOL.
+The form is to be used as the `common-lisp-indent-function' property
+in Emacs."
+ (if (and (macro-function symbol)
+ (not (known-to-emacs-p symbol)))
+ (let ((arglist (arglist symbol)))
+ (etypecase arglist
+ ((member :not-available)
+ nil)
+ (list
+ (macro-indentation arglist))))
+ nil))
+
+(defun macro-indentation (arglist)
+ (if (well-formed-list-p arglist)
+ (position '&body (remove '&optional (clean-arglist arglist)))
+ nil))
+
+(defun clean-arglist (arglist)
+ "Remove &whole, &enviroment, and &aux elements from ARGLIST."
+ (cond ((null arglist) '())
+ ((member (car arglist) '(&whole &environment))
+ (clean-arglist (cddr arglist)))
+ ((eq (car arglist) '&aux)
+ '())
+ (t (cons (car arglist) (clean-arglist (cdr arglist))))))
+
+(defun well-formed-list-p (list)
+ "Is LIST a proper list terminated by NIL?"
+ (typecase list
+ (null t)
+ (cons (well-formed-list-p (cdr list)))
+ (t nil)))
+
+(defun print-indentation-lossage (&optional (stream *standard-output*))
+ "Return the list of symbols whose indentation styles collide incompatibly.
+Collisions are caused because package information is ignored."
+ (let ((table (make-hash-table :test 'equal)))
+ (flet ((name (s) (string-downcase (symbol-name s))))
+ (do-all-symbols (s)
+ (setf (gethash (name s) table)
+ (cons s (symbol-indentation s))))
+ (let ((collisions '()))
+ (do-all-symbols (s)
+ (let* ((entry (gethash (name s) table))
+ (owner (car entry))
+ (indent (cdr entry)))
+ (unless (or (eq s owner)
+ (equal (symbol-indentation s) indent)
+ (and (not (fboundp s))
+ (null (macro-function s))))
+ (pushnew owner collisions)
+ (pushnew s collisions))))
+ (if (null collisions)
+ (format stream "~&No worries!~%")
+ (format stream "~&Symbols with collisions:~%~{ ~S~%~}"
+ collisions))))))
+
+(add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
+
+;;; swank.lisp ends here
Added: branches/bos/thirdparty/emacs/slime/test-all.sh
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/test-all.sh Fri Jan 18 06:05:59 2008
@@ -0,0 +1,14 @@
+#!/bin/sh
+
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
+trap EXIT
+
+for emacs in xemacs ; do # emacs-20.7 emacs-21.3.50 xemacs ; do
+ for lisp in 'cmucl -noinit' sbcl lispworks-personal-4300 'clisp -K full' acl5; do
+ echo testing: $emacs $lisp dribble.$emacs_$lisp result.$emacs_$lisp
+ test.sh $emacs "$lisp" "dribble.${emacs}_${lisp}" "result.${emacs}_${lisp}"
+ done
+done
+
\ No newline at end of file
Added: branches/bos/thirdparty/emacs/slime/test.sh
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/test.sh Fri Jan 18 06:05:59 2008
@@ -0,0 +1,82 @@
+#!/bin/sh
+
+# Run the SLIME test suite inside screen, saving the results to a file.
+
+# This script's exit status is the number of tests failed. If no tests
+# fail then no output is printed. If at least one test fails then a
+# one-line summary is printed.
+
+# If something unexpected fails, you might get an exit code like 127
+# or 255 instead. Sorry.
+
+# This code has been placed in the Public Domain. All warranties
+# are disclaimed.
+
+function usage () {
+ echo "Usage: $name [-v] [-r] <emacs> <lisp>"
+ exit 1
+}
+
+name=$0
+
+while getopts vr opt; do
+ case $opt in
+ v) verbose=true;;
+ r) dump_results=true;;
+ *) usage;;
+ esac
+done
+
+shift $((OPTIND - 1))
+[ $# = 2 ] || usage
+
+emacs=$1; lisp=$2;
+
+# Move the code into a directory in /tmp, so that we can compile it
+# for the current lisp.
+
+slimedir=$(dirname $name)
+testdir=/tmp/slime-test.$$
+results=$testdir/results
+dribble=$testdir/dribble
+statusfile=$testdir/status
+
+test -d $testdir && rm -r $testdir
+
+trap "rm -r $testdir" EXIT # remove temporary directory on exit
+
+mkdir $testdir
+cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib $testdir
+mkfifo $dribble
+
+session=slime-screen.$$
+
+screen -S $session -m -D bash -c "$emacs -nw -q -no-site-file --no-site-file \
+ --eval '(setq debug-on-quit t)' \
+ --eval '(setq max-lisp-eval-depth 1000)' \
+ --eval '(setq load-path (cons \"$testdir\" load-path))' \
+ --eval '(require (quote slime))' \
+ --eval '(setq inferior-lisp-program \"$lisp\")' \
+ --eval '(slime-batch-test \"$results\")' > $dribble;\
+ echo \$? > $statusfile" &
+
+screenpid=$!
+
+if [ "$verbose" = true ]; then
+ cat $dribble &
+else
+ cat $dribble > /dev/null &
+fi;
+
+trap "screen -S $session -X quit" SIGINT
+wait $screenpid
+
+if [ -f "$statusfile" ]; then
+ [ "$dump_results" = true ] && cat $results;
+ echo $(cat $statusfile) "test(s) failed."
+else
+ # Tests crashed
+ echo crashed
+fi
+
+exit $status
Added: branches/bos/thirdparty/emacs/slime/xref.lisp
==============================================================================
--- (empty file)
+++ branches/bos/thirdparty/emacs/slime/xref.lisp Fri Jan 18 06:05:59 2008
@@ -0,0 +1,2891 @@
+;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp; -*-
+;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz <mkant(a)GLINDA.OZ.CS.CMU.EDU>
+;;; xref.lisp
+
+;;; ****************************************************************
+;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp
+;;; ****************************************************************
+;;;
+;;; The List Callers system is a portable Common Lisp cross referencing
+;;; utility. It grovels over a set of files and compiles a database of the
+;;; locations of all references for each symbol used in the files.
+;;; List Callers is similar to the Symbolics Who-Calls and the
+;;; Xerox Masterscope facilities.
+;;;
+;;; When you change a function or variable definition, it can be useful
+;;; to know its callers, in order to update each of them to the new
+;;; definition. Similarly, having a graphic display of the structure
+;;; (e.g., call graph) of a program can help make undocumented code more
+;;; understandable. This static code analyzer facilitates both capabilities.
+;;; The database compiled by xref is suitable for viewing by a graphical
+;;; browser. (Note: the reference graph is not necessarily a DAG. Since many
+;;; graphical browsers assume a DAG, this will lead to infinite loops.
+;;; Some code which is useful in working around this problem is included,
+;;; as well as a sample text-indenting outliner and an interface to Bates'
+;;; PSGraph Postscript Graphing facility.)
+;;;
+;;; Written by Mark Kantrowitz, July 1990.
+;;;
+;;; Address: School of Computer Science
+;;; Carnegie Mellon University
+;;; Pittsburgh, PA 15213
+;;;
+;;; Copyright (c) 1990. All rights reserved.
+;;;
+;;; See general license below.
+;;;
+
+;;; ****************************************************************
+;;; General License Agreement and Lack of Warranty *****************
+;;; ****************************************************************
+;;;
+;;; This software is distributed in the hope that it will be useful (both
+;;; in and of itself and as an example of lisp programming), but WITHOUT
+;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
+;;; the consequences of using it or for whether it serves any particular
+;;; purpose or works at all. No warranty is made about the software or its
+;;; performance.
+;;;
+;;; Use and copying of this software and the preparation of derivative
+;;; works based on this software are permitted, so long as the following
+;;; conditions are met:
+;;; o The copyright notice and this entire notice are included intact
+;;; and prominently carried on all copies and supporting documentation.
+;;; o No fees or compensation are charged for use, copies, or
+;;; access to this software. You may charge a nominal
+;;; distribution fee for the physical act of transferring a
+;;; copy, but you may not charge for the program itself.
+;;; o If you modify this software, you must cause the modified
+;;; file(s) to carry prominent notices (a Change Log)
+;;; describing the changes, who made the changes, and the date
+;;; of those changes.
+;;; o Any work distributed or published that in whole or in part
+;;; contains or is a derivative of this software or any part
+;;; thereof is subject to the terms of this agreement. The
+;;; aggregation of another unrelated program with this software
+;;; or its derivative on a volume of storage or distribution
+;;; medium does not bring the other program under the scope
+;;; of these terms.
+;;; o Permission is granted to manufacturers and distributors of
+;;; lisp compilers and interpreters to include this software
+;;; with their distribution.
+;;;
+;;; This software is made available AS IS, and is distributed without
+;;; warranty of any kind, either expressed or implied.
+;;;
+;;; In no event will the author(s) or their institutions be liable to you
+;;; for damages, including lost profits, lost monies, or other special,
+;;; incidental or consequential damages arising out of or in connection
+;;; with the use or inability to use (including but not limited to loss of
+;;; data or data being rendered inaccurate or losses sustained by third
+;;; parties or a failure of the program to operate as documented) the
+;;; program, even if you have been advised of the possibility of such
+;;; damanges, or for any claim by any other party, whether in an action of
+;;; contract, negligence, or other tortious action.
+;;;
+;;; The current version of this software and a variety of related utilities
+;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory
+;;; user/ai/lang/lisp/code/tools/xref/
+;;;
+;;; Please send bug reports, comments, questions and suggestions to
+;;; mkant(a)cs.cmu.edu. We would also appreciate receiving any changes
+;;; or improvements you may make.
+;;;
+;;; If you wish to be added to the Lisp-Utilities(a)cs.cmu.edu mailing list,
+;;; send email to Lisp-Utilities-Request(a)cs.cmu.edu with your name, email
+;;; address, and affiliation. This mailing list is primarily for
+;;; notification about major updates, bug fixes, and additions to the lisp
+;;; utilities collection. The mailing list is intended to have low traffic.
+;;;
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript
+;;; graphs to be inserted in Scribe documents.
+;;; 21-FEB-91 mk Added warning if not compiled.
+;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at
+;;; toplevel.
+;;; 21-JAN-91 mk Added file xref-test.lisp to test xref.
+;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax.
+;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also
+;;; added parameter *handle-macro-forms*, defaulting to T.
+;;; 16-JAN-91 mk Modified print-caller-tree and related functions
+;;; to allow the user to specify root nodes. If the user
+;;; doesn't specify them, it will default to all root
+;;; nodes, as before.
+;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify
+;;; the direction of the graphing. Either :call-graph,
+;;; where the children of a node are those functions called
+;;; by the node, or :caller-graph where the children of a
+;;; node are the callers of the node. :call-graph is the
+;;; default.
+;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation
+;;; in print-indented-tree.
+;;; 16-JUL-90 mk Functions with argument lists of () were being ignored
+;;; because of a (when form) wrapped around the body of
+;;; record-callers. Then intent of (when form) was as an extra
+;;; safeguard against infinite looping. This wasn't really
+;;; necessary, so it has been removed.
+;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of
+;;; optionals.
+;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the
+;;; CLOS class hierarchy. This really doesn't belong here,
+;;; and should be moved to psgraph.lisp as an example of how
+;;; to use psgraph.
+;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member
+;;; had an error which caused many references to be missed.
+;;; 16-JUL-90 mk Added ability to save/load processed databases.
+;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the
+;;; source is loaded.
+;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself.
+;;; The arg to macro-function must be a symbol.
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;; Verify that:
+;;; o null forms don't cause it to infinite loop.
+;;; o nil matches against null argument lists.
+;;; o declarations and doc are being ignored.
+;;;
+;;; Would be nice if in addition to showing callers of a function, it
+;;; displayed the context of the calls to the function (e.g., the
+;;; immediately surrounding form). This entails storing entries of
+;;; the form (symbol context*) in the database and augmenting
+;;; record-callers to keep the context around. The only drawbacks is
+;;; that it would cons a fair bit. If we do this, we should store
+;;; additional information as well in the database, such as the caller
+;;; pattern type (e.g., variable vs. function).
+;;;
+;;; Write a translator from BNF (at least as much of BNF as is used
+;;; in CLtL2), to the format used here.
+;;;
+;;; Should automatically add new patterns for new functions and macros
+;;; based on their arglists. Probably requires much more than this
+;;; simple code walker, so there isn't much we can do.
+;;;
+;;; Defmacro is a problem, because it often hides internal function
+;;; calls within backquote and quote, which we normally ignore. If
+;;; we redefine QUOTE's pattern so that it treats the arg like a FORM,
+;;; we'll probably get them (though maybe the syntax will be mangled),
+;;; but most likely a lot of spurious things as well.
+;;;
+;;; Define an operation for Defsystem which will run XREF-FILE on the
+;;; files of the system. Or yet simpler, when XREF sees a LOAD form
+;;; for which the argument is a string, tries to recursively call
+;;; XREF-FILE on the specified file. Then one could just XREF-FILE
+;;; the file which loads the system. (This should be a program
+;;; parameter.)
+;;;
+;;; Have special keywords which the user may place in a file to have
+;;; XREF-FILE ignore a region.
+;;;
+;;; Should we distinguish flet and labels from defun? I.e., note that
+;;; flet's definitions are locally defined, instead of just lumping
+;;; them in with regular definitions.
+;;;
+;;; Add patterns for series, loop macro.
+;;;
+;;; Need to integrate the variable reference database with the other
+;;; databases, yet maintain separation. So we can distinguish all
+;;; the different types of variable and function references, without
+;;; multiplying databases.
+;;;
+;;; Would pay to comment record-callers and record-callers* in more
+;;; depth.
+;;;
+;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT)
+
+;;; ********************************
+;;; Notes **************************
+;;; ********************************
+;;;
+;;; XREF has been tested (successfully) in the following lisps:
+;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
+;;; Macintosh Allegro Common Lisp (1.3.2)
+;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90)
+;;; Lucid CL (Version 2.1 6-DEC-87)
+;;;
+;;; XREF has been tested (unsuccessfully) in the following lisps:
+;;; Ibuki Common Lisp (01/01, October 15, 1987)
+;;; - if interpreted, runs into stack overflow
+;;; - does not compile (tried ibcl on Suns, PMAXes and RTs)
+;;; seems to be due to a limitation in the c compiler.
+;;;
+;;; XREF needs to be tested in the following lisps:
+;;; Symbolics Common Lisp (8.0)
+;;; Lucid Common Lisp (3.0, 4.0)
+;;; KCL (June 3, 1987 or later)
+;;; AKCL (1.86, June 30, 1987 or later)
+;;; TI (Release 4.1 or later)
+;;; Golden Common Lisp (3.1 IBM-PC)
+;;; VAXLisp (2.0, 3.1)
+;;; HP Common Lisp (same as Lucid?)
+;;; Procyon Common Lisp
+
+
+;;; ****************************************************************
+;;; Documentation **************************************************
+;;; ****************************************************************
+;;;
+;;; XREF analyzes a user's program, determining which functions call a
+;;; given function, and the location of where variables are bound/assigned
+;;; and used. The user may retrieve this information for either a single
+;;; symbol, or display the call graph of portions of the program
+;;; (including the entire program). This allows the programmer to debug
+;;; and document the program's structure.
+;;;
+;;; XREF is primarily intended for analyzing large programs, where it is
+;;; difficult, if not impossible, for the programmer to grasp the structure
+;;; of the whole program. Nothing precludes using XREF for smaller programs,
+;;; where it can be useful for inspecting the relationships between pieces
+;;; of the program and for documenting the program.
+;;;
+;;; Two aspects of the Lisp programming language greatly simplify the
+;;; analysis of Lisp programs:
+;;; o Lisp programs are naturally represented as data.
+;;; Successive definitions from a file are easily read in
+;;; as list structure.
+;;; o The basic syntax of Lisp is uniform. A list program
+;;; consists of a set of nested forms, where each form is
+;;; a list whose car is a tag (e.g., function name) that
+;;; specifies the structure of the rest of the form.
+;;; Thus Lisp programs, when represented as data, can be considered to be
+;;; parse trees. Given a grammar of syntax patterns for the language, XREF
+;;; recursively descends the parse tree for a given definition, computing
+;;; a set of relations that hold for the definition at each node in the
+;;; tree. For example, one kind of relation is that the function defined
+;;; by the definition calls the functions in its body. The relations are
+;;; stored in a database for later examination by the user.
+;;;
+;;; While XREF currently only works for programs written in Lisp, it could
+;;; be extended to other programming languages by writing a function to
+;;; generate parse trees for definitions in that language, and a core
+;;; set of patterns for the language's syntax.
+;;;
+;;; Since XREF normally does a static syntactic analysis of the program,
+;;; it does not detect references due to the expansion of a macro definition.
+;;; To do this in full generality XREF would have to have knowledge about the
+;;; semantics of the program (e.g., macros which call other functions to
+;;; do the expansion). This entails either modifying the compiler to
+;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing
+;;; a walk of loaded code and macroexpanding as needed (PCL code walker).
+;;; The former is not portable, while the latter requires that the code
+;;; used by macros be loaded and in working order. On the other hand, then
+;;; we would need no special knowledge about macros (excluding the 24 special
+;;; forms of Lisp).
+;;;
+;;; Parameters may be set to enable macro expansion in XREF. Then XREF
+;;; will expand any macros for which it does not have predefined patterns.
+;;; (For example, most Lisps will implement dolist as a macro. Since XREF
+;;; has a pattern defined for dolist, it will not call macroexpand-1 on
+;;; a form whose car is dolist.) For this to work properly, the code must
+;;; be loaded before being processed by XREF, and XREF's parameters should
+;;; be set so that it processes forms in their proper packages.
+;;;
+;;; If macro expansion is disabled, the default rules for handling macro
+;;; references may not be sufficient for some user-defined macros, because
+;;; macros allow a variety of non-standard syntactic extensions to the
+;;; language. In this case, the user may specify additional templates in
+;;; a manner similar to that in which the core Lisp grammar was specified.
+;;;
+
+
+;;; ********************************
+;;; User Guide *********************
+;;; ********************************
+;;; -----
+;;; The following functions are called to cross reference the source files.
+;;;
+;;; XREF-FILES (&rest files) [FUNCTION]
+;;; Grovels over the lisp code located in source file FILES, using
+;;; xref-file.
+;;;
+;;; XREF-FILE (filename &optional clear-tables verbose) [Function]
+;;; Cross references the function and variable calls in FILENAME by
+;;; walking over the source code located in the file. Defaults type of
+;;; filename to ".lisp". Chomps on the code using record-callers and
+;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the
+;;; callers database before processing the file. Specify CLEAR-TABLES as
+;;; nil to append to the database. If VERBOSE is T (the default), prints
+;;; out the name of the file, one progress dot for each form processed,
+;;; and the total number of forms.
+;;;
+;;; -----
+;;; The following functions display information about the uses of the
+;;; specified symbol as a function, variable, or constant.
+;;;
+;;; LIST-CALLERS (symbol) [FUNCTION]
+;;; Lists all functions which call SYMBOL as a function (function
+;;; invocation).
+;;;
+;;; LIST-READERS (symbol) [FUNCTION]
+;;; Lists all functions which refer to SYMBOL as a variable
+;;; (variable reference).
+;;;
+;;; LIST-SETTERS (symbol) [FUNCTION]
+;;; Lists all functions which bind/set SYMBOL as a variable
+;;; (variable mutation).
+;;;
+;;; LIST-USERS (symbol) [FUNCTION]
+;;; Lists all functions which use SYMBOL as a variable or function.
+;;;
+;;; WHO-CALLS (symbol &optional how) [FUNCTION]
+;;; Lists callers of symbol. HOW may be :function, :reader, :setter,
+;;; or :variable."
+;;;
+;;; WHAT-FILES-CALL (symbol) [FUNCTION]
+;;; Lists names of files that contain uses of SYMBOL
+;;; as a function, variable, or constant.
+;;;
+;;; SOURCE-FILE (symbol) [FUNCTION]
+;;; Lists the names of files in which SYMBOL is defined/used.
+;;;
+;;; LIST-CALLEES (symbol) [FUNCTION]
+;;; Lists names of functions and variables called by SYMBOL.
+;;;
+;;; -----
+;;; The following functions may be useful for viewing the database and
+;;; debugging the calling patterns.
+;;;
+;;; *LAST-FORM* () [VARIABLE]
+;;; The last form read from the file. Useful for figuring out what went
+;;; wrong when xref-file drops into the debugger.
+;;;
+;;; *XREF-VERBOSE* t [VARIABLE]
+;;; When T, xref-file(s) prints out the names of the files it looks at,
+;;; progress dots, and the number of forms read.
+;;;
+;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE]
+;;; Default set of caller types (as specified in the patterns) to ignore
+;;; in the database handling functions. :lisp is CLtL 1st edition,
+;;; :lisp2 is additional patterns from CLtL 2nd edition.
+;;;
+;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE]
+;;; When non-NIL, and XREF-FILE sees a package-setting form like
+;;; IN-PACKAGE, sets the current package to the specified package by
+;;; evaluating the form. When done with the file, xref-file resets the
+;;; package to its original value. In some of the displaying functions,
+;;; when this variable is non-NIL one may specify that all symbols from a
+;;; particular set of packages be ignored. This is only useful if the
+;;; files use different packages with conflicting names.
+;;;
+;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE]
+;;; When T, XREF-FILE tries to be smart about forms which occur in
+;;; a function position, such as lambdas and arbitrary Lisp forms.
+;;; If so, it recursively calls record-callers with pattern 'FORM.
+;;; If the form is a lambda, makes the caller a caller of
+;;; :unnamed-lambda.
+;;;
+;;; *HANDLE-MACRO-FORMS* t [VARIABLE]
+;;; When T, if the file was loaded before being processed by XREF, and
+;;; the car of a form is a macro, it notes that the parent calls the
+;;; macro, and then calls macroexpand-1 on the form.
+;;;
+;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE]
+;;; Specifies whether we graph up or down. If :call-graph, the children
+;;; of a node are the functions it calls. If :caller-graph, the
+;;; children of a node are the functions that call it.
+;;;
+;;; *INDENT-AMOUNT* 3 [VARIABLE]
+;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE.
+;;;
+;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION]
+;;; Prints out the name of each symbol and all its callers. Specify
+;;; database :callers (the default) to get function call references,
+;;; :file to the get files in which the symbol is called, :readers to get
+;;; variable references, and :setters to get variable binding and
+;;; assignments. Ignores functions of types listed in types-to-ignore.
+;;;
+;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION]
+;;; (types-to-ignore *types-to-ignore*)
+;;; compact root-nodes)
+;;; Prints the calling trees (which may actually be a full graph and not
+;;; necessarily a DAG) as indented text trees using
+;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children
+;;; of a node are the functions called by the node, or :caller-graph for
+;;; trees where the children of a node are the functions the node calls.
+;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the
+;;; patterns) to ignore in printing out the database. For example,
+;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is
+;;; a flag to tell the program to try to compact the trees a bit by not
+;;; printing trees if they have already been seen. ROOT-NODES is a list
+;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to
+;;; find all root nodes in the database.
+;;;
+;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION]
+;;; (types-to-ignore *types-to-ignore*)
+;;; compact)
+;;; Outputs list structure of a tree which roughly represents the
+;;; possibly cyclical structure of the caller database.
+;;; If mode is :call-graph, the children of a node are the functions
+;;; it calls. If mode is :caller-graph, the children of a node are the
+;;; functions that call it.
+;;; If compact is T, tries to eliminate the already-seen nodes, so
+;;; that the graph for a node is printed at most once. Otherwise it will
+;;; duplicate the node's tree (except for cycles). This is usefull
+;;; because the call tree is actually a directed graph, so we can either
+;;; duplicate references or display only the first one.
+;;;
+;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION]
+;;; Makes a hash table of file dependencies for the references listed in
+;;; DATABASE. This function may be useful for automatically resolving
+;;; file references for automatic creation of a system definition
+;;; (defsystem).
+;;;
+;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION]
+;;; Prints a list of file dependencies for the references listed in
+;;; DATABASE. This function may be useful for automatically computing
+;;; file loading constraints for a system definition tool.
+;;;
+;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION]
+;;; Saves the contents of the current callers database to a file. This
+;;; file can be loaded to restore the previous contents of the
+;;; database. (For large systems it can take a long time to crunch
+;;; through the code, so this can save some time.)
+;;;
+;;; -----
+;;; The following macros define new function and macro call patterns.
+;;; They may be used to extend the static analysis tool to handle
+;;; new def forms, extensions to Common Lisp, and program defs.
+;;;
+;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO]
+;;; Defines NAME to be equivalent to the specified pattern. Useful for
+;;; making patterns more readable. For example, the LAMBDA-LIST is
+;;; defined as a pattern substitution, making the definition of the
+;;; DEFUN caller-pattern simpler.
+;;;
+;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO]
+;;; Defines NAME as a function/macro call with argument structure
+;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to
+;;; the pattern, which may be used to exclude references to NAME while
+;;; viewing the database. For example, all the Common Lisp definitions
+;;; have a caller-type of :lisp or :lisp2, so that you can exclude
+;;; references to common lisp functions from the calling tree.
+;;;
+;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO]
+;;; Defines NAME as a variable reference of type CALLER-TYPE. This is
+;;; mainly used to establish the caller-type of the variable.
+;;;
+;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO]
+;;; For defining function caller pattern syntax synonyms. For each name
+;;; in DESTINATIONS, defines its pattern as a copy of the definition
+;;; of SOURCE. Allows a large number of identical patterns to be defined
+;;; simultaneously. Must occur after the SOURCE has been defined.
+;;;
+;;; -----
+;;; This system includes pattern definitions for the latest
+;;; common lisp specification, as published in Guy Steele,
+;;; Common Lisp: The Language, 2nd Edition.
+;;;
+;;; Patterns may be either structures to match, or a predicate
+;;; like symbolp/numberp/stringp. The pattern specification language
+;;; is similar to the notation used in CLtL2, but in a more lisp-like
+;;; form:
+;;; (:eq name) The form element must be eq to the symbol NAME.
+;;; (:test test) TEST must be true when applied to the form element.
+;;; (:typep type) The form element must be of type TYPE.
+;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order,
+;;; until one succeeds.
+;;; Equivalent to { pat1 | pat2 | ... }
+;;; (:rest pattern) The remaining form elements are grouped into a
+;;; list which is matched against PATTERN.
+;;; (:optional pat1 ...) The patterns may optionally match against the
+;;; form element.
+;;; Equivalent to [ pat1 ... ].
+;;; (:star pat1 ...) The patterns may match against the patterns
+;;; any number of times, including 0.
+;;; Equivalent to { pat1 ... }*.
+;;; (:plus pat1 ...) The patterns may match against the patterns
+;;; any number of times, but at least once.
+;;; Equivalent to { pat1 ... }+.
+;;; &optional, &key, Similar in behavior to the corresponding
+;;; &rest lambda-list keywords.
+;;; FORM A random lisp form. If a cons, assumes the
+;;; car is a function or macro and tries to
+;;; match the args against that symbol's pattern.
+;;; If a symbol, assumes it's a variable reference.
+;;; :ignore Ignores the corresponding form element.
+;;; NAME The corresponding form element should be
+;;; the name of a new definition (e.g., the
+;;; first arg in a defun pattern is NAME.
+;;; FUNCTION, MACRO The corresponding form element should be
+;;; a function reference not handled by FORM.
+;;; Used in the definition of apply and funcall.
+;;; VAR The corresponding form element should be
+;;; a variable definition or mutation. Used
+;;; in the definition of let, let*, etc.
+;;; VARIABLE The corresponding form element should be
+;;; a variable reference.
+;;;
+;;; In all other pattern symbols, it looks up the symbols pattern substitution
+;;; and recursively matches against the pattern. Automatically destructures
+;;; list structure that does not include consing dots.
+;;;
+;;; Among the pattern substitution names defined are:
+;;; STRING, SYMBOL, NUMBER Appropriate :test patterns.
+;;; LAMBDA-LIST Matches against a lambda list.
+;;; BODY Matches against a function body definition.
+;;; FN Matches against #'function, 'function,
+;;; and lambdas. This is used in the definition
+;;; of apply, funcall, and the mapping patterns.
+;;; and others...
+;;;
+;;; Here's some sample pattern definitions:
+;;; (define-caller-pattern defun
+;;; (name lambda-list
+;;; (:star (:or documentation-string declaration))
+;;; (:star form))
+;;; :lisp)
+;;; (define-caller-pattern funcall (fn (:star form)) :lisp)
+;;;
+;;; In general, the system is intelligent enough to handle any sort of
+;;; simple funcall. One only need specify the syntax for functions and
+;;; macros which use optional arguments, keyword arguments, or some
+;;; argument positions are special, such as in apply and funcall, or
+;;; to indicate that the function is of the specified caller type.
+;;;
+;;;
+;;; NOTES:
+;;;
+;;; XRef assumes syntactically correct lisp code.
+;;;
+;;; This is by no means perfect. For example, let and let* are treated
+;;; identically, instead of differentiating between serial and parallel
+;;; binding. But it's still a useful tool. It can be helpful in
+;;; maintaining code, debugging problems with patch files, determining
+;;; whether functions are multiply defined, and help you remember where
+;;; a function is defined or called.
+;;;
+;;; XREF runs best when compiled.
+
+;;; ********************************
+;;; References *********************
+;;; ********************************
+;;;
+;;; Xerox Interlisp Masterscope Program:
+;;; Larry M Masinter, Global program analysis in an interactive environment
+;;; PhD Thesis, Stanford University, 1980.
+;;;
+;;; Symbolics Who-Calls Database:
+;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986
+;;; Genera 7.0, pp 183-185.
+;;;
+
+;;; ********************************
+;;; Example ************************
+;;; ********************************
+;;;
+;;; Here is an example of running XREF on a short program.
+;;; [In Scribe documentation, give a simple short program and resulting
+;;; XREF output, including postscript call graphs.]
+#|
+<cl> (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp")
+Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp.
+................................................
+48 forms processed.
+<cl> (xref:display-database :readers)
+
+*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
+*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE.
+*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO.
+*DIRECTION* is referenced by CREATE-POSITION-INFO.
+*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT.
+*ROOT-IS-SEQUENCE* is referenced by GRAPH.
+*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE.
+*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
+*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO.
+*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE.
+*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE.
+*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE.
+<cl> (xref:print-caller-trees :root-nodes '(display-graph))
+
+Rooted calling trees:
+ DISPLAY-GRAPH
+ CREATE-POSITION-INFO
+ CALCULATE-POSITION-INFO
+ CALCULATE-POSITION
+ NODE-POSITION-ALREADY-SET-FLAG
+ NODE-LEVEL-ALREADY-SET-FLAG
+ CALCULATE-POSITION-IN-LEVEL
+ NODE-CHILDREN
+ NODE-LEVEL
+ CALCULATE-POSITION
+ NEW-CALCULATE-BREADTH
+ NODE-CHILDREN
+ BREADTH
+ OPPOSITE-DIMENSION
+ NODE-HEIGHT
+ NODE-WIDTH
+ NEW-CALCULATE-BREADTH
+ NODE-PARENTS
+ OPPOSITE-DIMENSION
+ NODE-HEIGHT
+ NODE-WIDTH
+ OPPOSITE-POSITION
+ NODE-Y
+ NODE-X
+ NODE-LEVEL
+ CALCULATE-LEVEL-POSITION
+ NODE-LEVEL
+ NODE-POSITION
+ NODE-X
+ NODE-Y
+ DIMENSION
+ NODE-WIDTH
+ NODE-HEIGHT
+ CALCULATE-LEVEL-POSITION-BEFORE
+ NODE-LEVEL
+ NODE-POSITION
+ NODE-X
+ NODE-Y
+ NODE-WIDTH
+ NODE-HEIGHT
+ DIMENSION
+ NODE-WIDTH
+ NODE-HEIGHT
+|#
+
+;;; ****************************************************************
+;;; List Callers ***************************************************
+;;; ****************************************************************
+
+(defpackage :pxref
+ (:use :common-lisp)
+ (:export #:list-callers
+ #:list-users
+ #:list-readers
+ #:list-setters
+ #:what-files-call
+ #:who-calls
+ #:list-callees
+ #:source-file
+ #:clear-tables
+ #:define-pattern-substitution
+ #:define-caller-pattern
+ #:define-variable-pattern
+ #:define-caller-pattern-synonyms
+ #:clear-patterns
+ #:*last-form*
+ #:*xref-verbose*
+ #:*handle-package-forms*
+ #:*handle-function-forms*
+ #:*handle-macro-forms*
+ #:*types-to-ignore*
+ #:*last-caller-tree*
+ #:*default-graphing-mode*
+ #:*indent-amount*
+ #:xref-file
+ #:xref-files
+ #:write-callers-database-to-file
+ #:display-database
+ #:print-caller-trees
+ #:make-caller-tree
+ #:print-indented-tree
+ #:determine-file-dependencies
+ #:print-file-dependencies
+ #:psgraph-xref
+ ))
+
+(in-package "PXREF")
+
+;;; Warn user if they're loading the source instead of compiling it first.
+;(eval-when (compile load eval)
+; (defvar compiled-p nil))
+;(eval-when (compile load)
+; (setq compiled-p t))
+;(eval-when (load eval)
+; (unless compiled-p
+; (warn "This file should be compiled before loading for best results.")))
+(eval-when (eval)
+ (warn "This file should be compiled before loading for best results."))
+
+
+;;; ********************************
+;;; Primitives *********************
+;;; ********************************
+(defun lookup (symbol environment)
+ (dolist (frame environment)
+ (when (member symbol frame)
+ (return symbol))))
+
+(defun car-eq (list item)
+ (and (consp list)
+ (eq (car list) item)))
+
+;;; ********************************
+;;; Callers Database ***************
+;;; ********************************
+(defvar *file-callers-database* (make-hash-table :test #'equal)
+ "Contains name and list of file callers (files which call) for that name.")
+(defvar *callers-database* (make-hash-table :test #'equal)
+ "Contains name and list of callers (function invocation) for that name.")
+(defvar *readers-database* (make-hash-table :test #'equal)
+ "Contains name and list of readers (variable use) for that name.")
+(defvar *setters-database* (make-hash-table :test #'equal)
+ "Contains name and list of setters (variable mutation) for that name.")
+(defvar *callees-database* (make-hash-table :test #'equal)
+ "Contains name and list of functions and variables it calls.")
+(defun callers-list (name &optional (database :callers))
+ (case database
+ (:file (gethash name *file-callers-database*))
+ (:callees (gethash name *callees-database*))
+ (:callers (gethash name *callers-database*))
+ (:readers (gethash name *readers-database*))
+ (:setters (gethash name *setters-database*))))
+(defsetf callers-list (name &optional (database :callers)) (caller)
+ `(setf (gethash ,name (case ,database
+ (:file *file-callers-database*)
+ (:callees *callees-database*)
+ (:callers *callers-database*)
+ (:readers *readers-database*)
+ (:setters *setters-database*)))
+ ,caller))
+
+(defun list-callers (symbol)
+ "Lists all functions which call SYMBOL as a function (function invocation)."
+ (callers-list symbol :callers))
+(defun list-readers (symbol)
+ "Lists all functions which refer to SYMBOL as a variable
+ (variable reference)."
+ (callers-list symbol :readers))
+(defun list-setters (symbol)
+ "Lists all functions which bind/set SYMBOL as a variable
+ (variable mutation)."
+ (callers-list symbol :setters))
+(defun list-users (symbol)
+ "Lists all functions which use SYMBOL as a variable or function."
+ (values (list-callers symbol)
+ (list-readers symbol)
+ (list-setters symbol)))
+(defun who-calls (symbol &optional how)
+ "Lists callers of symbol. HOW may be :function, :reader, :setter,
+ or :variable."
+ ;; would be nice to have :macro and distinguish variable
+ ;; binding from assignment. (i.e., variable binding, assignment, and use)
+ (case how
+ (:function (list-callers symbol))
+ (:reader (list-readers symbol))
+ (:setter (list-setters symbol))
+ (:variable (append (list-readers symbol)
+ (list-setters symbol)))
+ (otherwise (append (list-callers symbol)
+ (list-readers symbol)
+ (list-setters symbol)))))
+(defun what-files-call (symbol)
+ "Lists names of files that contain uses of SYMBOL
+ as a function, variable, or constant."
+ (callers-list symbol :file))
+(defun list-callees (symbol)
+ "Lists names of functions and variables called by SYMBOL."
+ (callers-list symbol :callees))
+
+(defvar *source-file* (make-hash-table :test #'equal)
+ "Contains function name and source file for that name.")
+(defun source-file (symbol)
+ "Lists the names of files in which SYMBOL is defined/used."
+ (gethash symbol *source-file*))
+(defsetf source-file (name) (value)
+ `(setf (gethash ,name *source-file*) ,value))
+
+(defun clear-tables ()
+ (clrhash *file-callers-database*)
+ (clrhash *callers-database*)
+ (clrhash *callees-database*)
+ (clrhash *readers-database*)
+ (clrhash *setters-database*)
+ (clrhash *source-file*))
+
+
+;;; ********************************
+;;; Pattern Database ***************
+;;; ********************************
+;;; Pattern Types
+(defvar *pattern-caller-type* (make-hash-table :test #'equal))
+(defun pattern-caller-type (name)
+ (gethash name *pattern-caller-type*))
+(defsetf pattern-caller-type (name) (value)
+ `(setf (gethash ,name *pattern-caller-type*) ,value))
+
+;;; Pattern Substitutions
+(defvar *pattern-substitution-table* (make-hash-table :test #'equal)
+ "Stores general patterns for function destructuring.")
+(defun lookup-pattern-substitution (name)
+ (gethash name *pattern-substitution-table*))
+(defmacro define-pattern-substitution (name pattern)
+ "Defines NAME to be equivalent to the specified pattern. Useful for
+ making patterns more readable. For example, the LAMBDA-LIST is
+ defined as a pattern substitution, making the definition of the
+ DEFUN caller-pattern simpler."
+ `(setf (gethash ',name *pattern-substitution-table*)
+ ',pattern))
+
+;;; Function/Macro caller patterns:
+;;; The car of the form is skipped, so we don't need to specify
+;;; (:eq function-name) like we would for a substitution.
+;;;
+;;; Patterns must be defined in the XREF package because the pattern
+;;; language is tested by comparing symbols (using #'equal) and not
+;;; their printreps. This is fine for the lisp grammer, because the XREF
+;;; package depends on the LISP package, so a symbol like 'xref::cons is
+;;; translated automatically into 'lisp::cons. However, since
+;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and
+;;; 'baz::bar are inherited from the same package (e.g., LISP),
+;;; if package handling is turned on the user must specify package
+;;; names in the caller pattern definitions for functions that occur
+;;; in packages other than LISP, otherwise the symbols will not match.
+;;;
+;;; Perhaps we should enforce the definition of caller patterns in the
+;;; XREF package by wrapping the body of define-caller-pattern in
+;;; the XREF package:
+;;; (defmacro define-caller-pattern (name value &optional caller-type)
+;;; (let ((old-package *package*))
+;;; (setf *package* (find-package "XREF"))
+;;; (prog1
+;;; `(progn
+;;; (when ',caller-type
+;;; (setf (pattern-caller-type ',name) ',caller-type))
+;;; (when ',value
+;;; (setf (gethash ',name *caller-pattern-table*)
+;;; ',value)))
+;;; (setf *package* old-package))))
+;;; Either that, or for the purpose of pattern testing we should compare
+;;; printreps. [The latter makes the primitive patterns like VAR
+;;; reserved words.]
+(defvar *caller-pattern-table* (make-hash-table :test #'equal)
+ "Stores patterns for function destructuring.")
+(defun lookup-caller-pattern (name)
+ (gethash name *caller-pattern-table*))
+(defmacro define-caller-pattern (name pattern &optional caller-type)
+ "Defines NAME as a function/macro call with argument structure
+ described by PATTERN. CALLER-TYPE, if specified, assigns a type to
+ the pattern, which may be used to exclude references to NAME while
+ viewing the database. For example, all the Common Lisp definitions
+ have a caller-type of :lisp or :lisp2, so that you can exclude
+ references to common lisp functions from the calling tree."
+ `(progn
+ (when ',caller-type
+ (setf (pattern-caller-type ',name) ',caller-type))
+ (when ',pattern
+ (setf (gethash ',name *caller-pattern-table*)
+ ',pattern))))
+
+;;; For defining variables
+(defmacro define-variable-pattern (name &optional caller-type)
+ "Defines NAME as a variable reference of type CALLER-TYPE. This is
+ mainly used to establish the caller-type of the variable."
+ `(progn
+ (when ',caller-type
+ (setf (pattern-caller-type ',name) ',caller-type))))
+
+;;; For defining synonyms. Means much less space taken up by the patterns.
+(defmacro define-caller-pattern-synonyms (source destinations)
+ "For defining function caller pattern syntax synonyms. For each name
+ in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE.
+ Allows a large number of identical patterns to be defined simultaneously.
+ Must occur after the SOURCE has been defined."
+ `(let ((source-type (pattern-caller-type ',source))
+ (source-pattern (gethash ',source *caller-pattern-table*)))
+ (when source-type
+ (dolist (dest ',destinations)
+ (setf (pattern-caller-type dest) source-type)))
+ (when source-pattern
+ (dolist (dest ',destinations)
+ (setf (gethash dest *caller-pattern-table*)
+ source-pattern)))))
+
+(defun clear-patterns ()
+ (clrhash *pattern-substitution-table*)
+ (clrhash *caller-pattern-table*)
+ (clrhash *pattern-caller-type*))
+
+;;; ********************************
+;;; Cross Reference Files **********
+;;; ********************************
+(defvar *last-form* ()
+ "The last form read from the file. Useful for figuring out what went wrong
+ when xref-file drops into the debugger.")
+
+(defvar *xref-verbose* t
+ "When T, xref-file(s) prints out the names of the files it looks at,
+ progress dots, and the number of forms read.")
+
+;;; This needs to first clear the tables?
+(defun xref-files (&rest files)
+ "Grovels over the lisp code located in source file FILES, using xref-file."
+ ;; If the arg is a list, use it.
+ (when (listp (car files)) (setq files (car files)))
+ (dolist (file files)
+ (xref-file file nil))
+ (values))
+
+(defvar *handle-package-forms* nil ;'(lisp::in-package)
+ "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE,
+ sets the current package to the specified package by evaluating the
+ form. When done with the file, xref-file resets the package to its
+ original value. In some of the displaying functions, when this variable
+ is non-NIL one may specify that all symbols from a particular set of
+ packages be ignored. This is only useful if the files use different
+ packages with conflicting names.")
+
+(defvar *normal-readtable* (copy-readtable nil)
+ "Normal, unadulterated CL readtable.")
+
+(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*))
+ "Cross references the function and variable calls in FILENAME by
+ walking over the source code located in the file. Defaults type of
+ filename to \".lisp\". Chomps on the code using record-callers and
+ record-callers*. If CLEAR-TABLES is T (the default), it clears the callers
+ database before processing the file. Specify CLEAR-TABLES as nil to
+ append to the database. If VERBOSE is T (the default), prints out the
+ name of the file, one progress dot for each form processed, and the
+ total number of forms."
+ ;; Default type to "lisp"
+ (when (and (null (pathname-type filename))
+ (not (probe-file filename)))
+ (cond ((stringp filename)
+ (setf filename (concatenate 'string filename ".lisp")))
+ ((pathnamep filename)
+ (setf filename (merge-pathnames filename
+ (make-pathname :type "lisp"))))))
+ (when clear-tables (clear-tables))
+ (let ((count 0)
+ (old-package *package*)
+ (*readtable* *normal-readtable*))
+ (when verbose
+ (format t "~&Cross-referencing file ~A.~&" filename))
+ (with-open-file (stream filename :direction :input)
+ (do ((form (read stream nil :eof) (read stream nil :eof)))
+ ((eq form :eof))
+ (incf count)
+ (when verbose
+ (format *standard-output* ".")
+ (force-output *standard-output*))
+ (setq *last-form* form)
+ (record-callers filename form)
+ ;; Package Magic.
+ (when (and *handle-package-forms*
+ (consp form)
+ (member (car form) *handle-package-forms*))
+ (eval form))))
+ (when verbose
+ (format t "~&~D forms processed." count))
+ (setq *package* old-package)
+ (values)))
+
+(defvar *handle-function-forms* t
+ "When T, XREF-FILE tries to be smart about forms which occur in
+ a function position, such as lambdas and arbitrary Lisp forms.
+ If so, it recursively calls record-callers with pattern 'FORM.
+ If the form is a lambda, makes the caller a caller of :unnamed-lambda.")
+
+(defvar *handle-macro-forms* t
+ "When T, if the file was loaded before being processed by XREF, and the
+ car of a form is a macro, it notes that the parent calls the macro,
+ and then calls macroexpand-1 on the form.")
+
+(defvar *callees-database-includes-variables* nil)
+
+(defun record-callers (filename form
+ &optional pattern parent (environment nil)
+ funcall)
+ "RECORD-CALLERS is the main routine used to walk down the code. It matches
+ the PATTERN against the FORM, possibly adding statements to the database.
+ PARENT is the name defined by the current outermost definition; it is
+ the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used
+ to keep track of the scoping of variables. FUNCALL deals with the type
+ of variable assignment and hence how the environment should be modified.
+ RECORD-CALLERS handles atomic patterns and simple list-structure patterns.
+ For complex list-structure pattern destructuring, it calls RECORD-CALLERS*."
+; (when form)
+ (unless pattern (setq pattern 'FORM))
+ (cond ((symbolp pattern)
+ (case pattern
+ (:IGNORE
+ ;; Ignores the rest of the form.
+ (values t parent environment))
+ (NAME
+ ;; This is the name of a new definition.
+ (push filename (source-file form))
+ (values t form environment))
+ ((FUNCTION MACRO)
+ ;; This is the name of a call.
+ (cond ((and *handle-function-forms* (consp form))
+ ;; If we're a cons and special handling is on,
+ (when (eq (car form) 'lambda)
+ (pushnew filename (callers-list :unnamed-lambda :file))
+ (when parent
+ (pushnew parent (callers-list :unnamed-lambda
+ :callers))
+ (pushnew :unnamed-lambda (callers-list parent
+ :callees))))
+ (record-callers filename form 'form parent environment))
+ (t
+ ;; If we're just a regular function name call.
+ (pushnew filename (callers-list form :file))
+ (when parent
+ (pushnew parent (callers-list form :callers))
+ (pushnew form (callers-list parent :callees)))
+ (values t parent environment))))
+ (VAR
+ ;; This is the name of a new variable definition.
+ ;; Includes arglist parameters.
+ (when (and (symbolp form) (not (keywordp form))
+ (not (member form lambda-list-keywords)))
+ (pushnew form (car environment))
+ (pushnew filename (callers-list form :file))
+ (when parent
+; (pushnew form (callers-list parent :callees))
+ (pushnew parent (callers-list form :setters)))
+ (values t parent environment)))
+ (VARIABLE
+ ;; VAR reference
+ (pushnew filename (callers-list form :file))
+ (when (and parent (not (lookup form environment)))
+ (pushnew parent (callers-list form :readers))
+ (when *callees-database-includes-variables*
+ (pushnew form (callers-list parent :callees))))
+ (values t parent environment))
+ (FORM
+ ;; A random form (var or funcall).
+ (cond ((consp form)
+ ;; Get new pattern from TAG.
+ (let ((new-pattern (lookup-caller-pattern (car form))))
+ (pushnew filename (callers-list (car form) :file))
+ (when parent
+ (pushnew parent (callers-list (car form) :callers))
+ (pushnew (car form) (callers-list parent :callees)))
+ (cond ((and new-pattern (cdr form))
+ ;; Special Pattern and there's stuff left
+ ;; to be processed. Note that we check if
+ ;; a pattern is defined for the form before
+ ;; we check to see if we can macroexpand it.
+ (record-callers filename (cdr form) new-pattern
+ parent environment :funcall))
+ ((and *handle-macro-forms*
+ (symbolp (car form)) ; pnorvig 9/9/93
+ (macro-function (car form)))
+ ;; The car of the form is a macro and
+ ;; macro processing is turned on. Macroexpand-1
+ ;; the form and try again.
+ (record-callers filename
+ (macroexpand-1 form)
+ 'form parent environment
+ :funcall))
+ ((null (cdr form))
+ ;; No more left to be processed. Note that
+ ;; this must occur after the macros clause,
+ ;; since macros can expand into more code.
+ (values t parent environment))
+ (t
+ ;; Random Form. We assume it is a function call.
+ (record-callers filename (cdr form)
+ '((:star FORM))
+ parent environment :funcall)))))
+ (t
+ (when (and (not (lookup form environment))
+ (not (numberp form))
+ ;; the following line should probably be
+ ;; commented out?
+ (not (keywordp form))
+ (not (stringp form))
+ (not (eq form t))
+ (not (eq form nil)))
+ (pushnew filename (callers-list form :file))
+ ;; ??? :callers
+ (when parent
+ (pushnew parent (callers-list form :readers))
+ (when *callees-database-includes-variables*
+ (pushnew form (callers-list parent :callees)))))
+ (values t parent environment))))
+ (otherwise
+ ;; Pattern Substitution
+ (let ((new-pattern (lookup-pattern-substitution pattern)))
+ (if new-pattern
+ (record-callers filename form new-pattern
+ parent environment)
+ (when (eq pattern form)
+ (values t parent environment)))))))
+ ((consp pattern)
+ (case (car pattern)
+ (:eq (when (eq (second pattern) form)
+ (values t parent environment)))
+ (:test (when (funcall (eval (second pattern)) form)
+ (values t parent environment)))
+ (:typep (when (typep form (second pattern))
+ (values t parent environment)))
+ (:or (dolist (subpat (rest pattern))
+ (multiple-value-bind (processed parent environment)
+ (record-callers filename form subpat
+ parent environment)
+ (when processed
+ (return (values processed parent environment))))))
+ (:rest ; (:star :plus :optional :rest)
+ (record-callers filename form (second pattern)
+ parent environment))
+ (otherwise
+ (multiple-value-bind (d p env)
+ (record-callers* filename form pattern
+ parent (cons nil environment))
+ (values d p (if funcall environment env))))))))
+
+(defun record-callers* (filename form pattern parent environment
+ &optional continuation
+ in-optionals in-keywords)
+ "RECORD-CALLERS* handles complex list-structure patterns, such as
+ ordered lists of subpatterns, patterns involving :star, :plus,
+ &optional, &key, &rest, and so on. CONTINUATION is a stack of
+ unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding
+ stacks which determine whether &rest or &key has been seen yet in
+ the current pattern."
+ ;; form must be a cons or nil.
+; (when form)
+ (if (null pattern)
+ (if (null continuation)
+ (values t parent environment)
+ (record-callers* filename form (car continuation) parent environment
+ (cdr continuation)
+ (cdr in-optionals)
+ (cdr in-keywords)))
+ (let ((pattern-elt (car pattern)))
+ (cond ((car-eq pattern-elt :optional)
+ (if (null form)
+ (values t parent environment)
+ (multiple-value-bind (processed par env)
+ (record-callers* filename form (cdr pattern-elt)
+ parent environment
+ (cons (cdr pattern) continuation)
+ (cons (car in-optionals) in-optionals)
+ (cons (car in-keywords) in-keywords))
+ (if processed
+ (values processed par env)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ in-optionals in-keywords)))))
+ ((car-eq pattern-elt :star)
+ (if (null form)
+ (values t parent environment)
+ (multiple-value-bind (processed par env)
+ (record-callers* filename form (cdr pattern-elt)
+ parent environment
+ (cons pattern continuation)
+ (cons (car in-optionals) in-optionals)
+ (cons (car in-keywords) in-keywords))
+ (if processed
+ (values processed par env)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ in-optionals in-keywords)))))
+ ((car-eq pattern-elt :plus)
+ (record-callers* filename form (cdr pattern-elt)
+ parent environment
+ (cons (cons (cons :star (cdr pattern-elt))
+ (cdr pattern))
+ continuation)
+ (cons (car in-optionals) in-optionals)
+ (cons (car in-keywords) in-keywords)))
+ ((car-eq pattern-elt :rest)
+ (record-callers filename form pattern-elt parent environment))
+ ((eq pattern-elt '&optional)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ (cons t in-optionals)
+ (cons (car in-keywords) in-keywords)))
+ ((eq pattern-elt '&rest)
+ (record-callers filename form (second pattern)
+ parent environment))
+ ((eq pattern-elt '&key)
+ (record-callers* filename form (cdr pattern)
+ parent environment continuation
+ (cons (car in-optionals) in-optionals)
+ (cons t in-keywords)))
+ ((null form)
+ (when (or (car in-keywords) (car in-optionals))
+ (values t parent environment)))
+ ((consp form)
+ (multiple-value-bind (processed parent environment)
+ (record-callers filename (if (car in-keywords)
+ (cadr form)
+ (car form))
+ pattern-elt
+ parent environment)
+ (cond (processed
+ (record-callers* filename (if (car in-keywords)
+ (cddr form)
+ (cdr form))
+ (cdr pattern)
+ parent environment
+ continuation
+ in-optionals in-keywords))
+ ((or (car in-keywords)
+ (car in-optionals))
+ (values t parent environment)))))))))
+
+
+;;; ********************************
+;;; Misc Utilities *****************
+;;; ********************************
+(defvar *types-to-ignore*
+ '(:lisp ; CLtL 1st Edition
+ :lisp2 ; CLtL 2nd Edition additional patterns
+ )
+ "Default set of caller types (as specified in the patterns) to ignore
+ in the database handling functions. :lisp is CLtL 1st edition,
+ :lisp2 is additional patterns from CLtL 2nd edition.")
+
+(defun display-database (&optional (database :callers)
+ (types-to-ignore *types-to-ignore*))
+ "Prints out the name of each symbol and all its callers. Specify database
+ :callers (the default) to get function call references, :fill to the get
+ files in which the symbol is called, :readers to get variable references,
+ and :setters to get variable binding and assignments. Ignores functions
+ of types listed in types-to-ignore."
+ (maphash #'(lambda (name callers)
+ (unless (or (member (pattern-caller-type name)
+ types-to-ignore)
+ ;; When we're doing fancy package crap,
+ ;; allow us to ignore symbols based on their
+ ;; packages.
+ (when *handle-package-forms*
+ (member (symbol-package name)
+ types-to-ignore
+ :key #'find-package)))
+ (format t "~&~S is referenced by~{ ~S~}."
+ name callers)))
+ (ecase database
+ (:file *file-callers-database*)
+ (:callers *callers-database*)
+ (:readers *readers-database*)
+ (:setters *setters-database*))))
+
+(defun write-callers-database-to-file (filename)
+ "Saves the contents of the current callers database to a file. This
+ file can be loaded to restore the previous contents of the
+ database. (For large systems it can take a long time to crunch
+ through the code, so this can save some time.)"
+ (with-open-file (stream filename :direction :output)
+ (format stream "~&(clear-tables)")
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (source-file '~S) '~S)"
+ x y))
+ *source-file*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :file) '~S)"
+ x y))
+ *file-callers-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :callers) '~S)"
+ x y))
+ *callers-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :callees) '~S)"
+ x y))
+ *callees-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :readers) '~S)"
+ x y))
+ *readers-database*)
+ (maphash #'(lambda (x y)
+ (format stream "~&(setf (callers-list '~S :setters) '~S)"
+ x y))
+ *setters-database*)))
+
+
+;;; ********************************
+;;; Print Caller Trees *************
+;;; ********************************
+;;; The following function is useful for reversing a caller table into
+;;; a callee table. Possibly later we'll extend xref to create two
+;;; such database hash tables. Needs to include vars as well.
+(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*))
+ "Makes a copy of the hash table in which (name value*) pairs
+ are inverted to (value name*) pairs."
+ (let ((target (make-hash-table :test #'equal)))
+ (maphash #'(lambda (key values)
+ (dolist (value values)
+ (unless (member (pattern-caller-type key)
+ types-to-ignore)
+ (pushnew key (gethash value target)))))
+ table)
+ target))
+
+;;; Resolve file references for automatic creation of a defsystem file.
+(defun determine-file-dependencies (&optional (database *callers-database*))
+ "Makes a hash table of file dependencies for the references listed in
+ DATABASE. This function may be useful for automatically resolving
+ file references for automatic creation of a system definition (defsystem)."
+ (let ((file-ref-ht (make-hash-table :test #'equal)))
+ (maphash #'(lambda (key values)
+ (let ((key-file (source-file key)))
+ (when key
+ (dolist (value values)
+ (let ((value-file (source-file value)))
+ (when value-file
+ (dolist (s key-file)
+ (dolist (d value-file)
+ (pushnew d (gethash s file-ref-ht))))))))))
+ database)
+ file-ref-ht))
+
+(defun print-file-dependencies (&optional (database *callers-database*))
+ "Prints a list of file dependencies for the references listed in DATABASE.
+ This function may be useful for automatically computing file loading
+ constraints for a system definition tool."
+ (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value))
+ (determine-file-dependencies database)))
+
+;;; The following functions demonstrate a possible way to interface
+;;; xref to a graphical browser such as psgraph to mimic the capabilities
+;;; of Masterscope's graphical browser.
+
+(defvar *last-caller-tree* nil)
+
+(defvar *default-graphing-mode* :call-graph
+ "Specifies whether we graph up or down. If :call-graph, the children
+ of a node are the functions it calls. If :caller-graph, the children
+ of a node are the functions that call it.")
+
+(defun gather-tree (parents &optional already-seen
+ (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*) compact)
+ "Extends the tree, copying it into list structure, until it repeats
+ a reference (hits a cycle)."
+ (let ((*already-seen* nil)
+ (database (case mode
+ (:call-graph *callees-database*)
+ (:caller-graph *callers-database*))))
+ (declare (special *already-seen*))
+ (labels
+ ((amass-tree
+ (parents &optional already-seen)
+ (let (result this-item)
+ (dolist (parent parents)
+ (unless (member (pattern-caller-type parent)
+ types-to-ignore)
+ (pushnew parent *already-seen*)
+ (if (member parent already-seen)
+ (setq this-item nil) ; :ignore
+ (if compact
+ (multiple-value-setq (this-item already-seen)
+ (amass-tree (gethash parent database)
+ (cons parent already-seen)))
+ (setq this-item
+ (amass-tree (gethash parent database)
+ (cons parent already-seen)))))
+ (setq parent (format nil "~S" parent))
+ (when (consp parent) (setq parent (cons :xref-list parent)))
+ (unless (eq this-item :ignore)
+ (push (if this-item
+ (list parent this-item)
+ parent)
+ result))))
+ (values result ;(reverse result)
+ already-seen))))
+ (values (amass-tree parents already-seen)
+ *already-seen*))))
+
+(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*))
+ "Returns a list of uncalled callers (roots) and called callers (potential
+ cycles)."
+ (let ((uncalled-callers nil)
+ (called-callers nil)
+ (database (ecase mode
+ (:call-graph *callers-database*)
+ (:caller-graph *callees-database*)))
+ (other-database (ecase mode
+ (:call-graph *callees-database*)
+ (:caller-graph *callers-database*))))
+ (maphash #'(lambda (name value)
+ (declare (ignore value))
+ (unless (member (pattern-caller-type name)
+ types-to-ignore)
+ (if (gethash name database)
+ (push name called-callers)
+ (push name uncalled-callers))))
+ other-database)
+ (values uncalled-callers called-callers)))
+
+(defun make-caller-tree (&optional (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*) compact)
+ "Outputs list structure of a tree which roughly represents the possibly
+ cyclical structure of the caller database.
+ If mode is :call-graph, the children of a node are the functions it calls.
+ If mode is :caller-graph, the children of a node are the functions that
+ call it.
+ If compact is T, tries to eliminate the already-seen nodes, so that
+ the graph for a node is printed at most once. Otherwise it will duplicate
+ the node's tree (except for cycles). This is usefull because the call tree
+ is actually a directed graph, so we can either duplicate references or
+ display only the first one."
+ ;; Would be nice to print out line numbers and whenever we skip a duplicated
+ ;; reference, print the line number of the full reference after the node.
+ (multiple-value-bind (uncalled-callers called-callers)
+ (find-roots-and-cycles mode types-to-ignore)
+ (multiple-value-bind (trees already-seen)
+ (gather-tree uncalled-callers nil mode types-to-ignore compact)
+ (setq *last-caller-tree* trees)
+ (let ((more-trees (gather-tree (set-difference called-callers
+ already-seen)
+ already-seen
+ mode types-to-ignore compact)))
+ (values trees more-trees)))))
+
+(defvar *indent-amount* 3
+ "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.")
+
+(defun print-indented-tree (trees &optional (indent 0))
+ "Simple code to print out a list-structure tree (such as those created
+ by make-caller-tree) as indented text."
+ (when trees
+ (dolist (tree trees)
+ (cond ((and (listp tree) (eq (car tree) :xref-list))
+ (format t "~&~VT~A" indent (cdr tree)))
+ ((listp tree)
+ (format t "~&~VT~A" indent (car tree))
+ (print-indented-tree (cadr tree) (+ indent *indent-amount*)))
+ (t
+ (format t "~&~VT~A" indent tree))))))
+
+(defun print-caller-trees (&key (mode *default-graphing-mode*)
+ (types-to-ignore *types-to-ignore*)
+ compact
+ root-nodes)
+ "Prints the calling trees (which may actually be a full graph and not
+ necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE.
+ MODE is :call-graph for trees where the children of a node are the
+ functions called by the node, or :caller-graph for trees where the
+ children of a node are the functions the node calls. TYPES-TO-IGNORE
+ is a list of funcall types (as specified in the patterns) to ignore
+ in printing out the database. For example, '(:lisp) would ignore all
+ calls to common lisp functions. COMPACT is a flag to tell the program
+ to try to compact the trees a bit by not printing trees if they have
+ already been seen. ROOT-NODES is a list of root nodes of trees to
+ display. If ROOT-NODES is nil, tries to find all root nodes in the
+ database."
+ (multiple-value-bind (rooted cycles)
+ (if root-nodes
+ (values (gather-tree root-nodes nil mode types-to-ignore compact))
+ (make-caller-tree mode types-to-ignore compact))
+ (when rooted
+ (format t "~&Rooted calling trees:")
+ (print-indented-tree rooted 2))
+ (when cycles
+ (when rooted
+ (format t "~2%"))
+ (format t "~&Cyclic calling trees:")
+ (print-indented-tree cycles 2))))
+
+
+;;; ********************************
+;;; Interface to PSGraph ***********
+;;; ********************************
+#|
+;;; Interface to Bates' PostScript Graphing Utility
+(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph")
+
+(defparameter *postscript-output-directory* "")
+(defun psgraph-xref (&key (mode *default-graphing-mode*)
+ (output-directory *postscript-output-directory*)
+ (types-to-ignore *types-to-ignore*)
+ (compact t)
+ (shrink t)
+ root-nodes
+ insert)
+ ;; If root-nodes is a non-nil list, uses that list as the starting
+ ;; position. Otherwise tries to find all roots in the database.
+ (multiple-value-bind (rooted cycles)
+ (if root-nodes
+ (values (gather-tree root-nodes nil mode types-to-ignore compact))
+ (make-caller-tree mode types-to-ignore compact))
+ (psgraph-output (append rooted cycles) output-directory shrink insert)))
+
+(defun psgraph-output (list-of-trees directory shrink &optional insert)
+ (let ((psgraph:*fontsize* 9)
+ (psgraph:*second-fontsize* 7)
+; (psgraph:*boxkind* "fill")
+ (psgraph:*boxgray* "0") ; .8
+ (psgraph:*edgewidth* "1")
+ (psgraph:*edgegray* "0"))
+ (labels ((stringify (thing)
+ (cond ((stringp thing) (string-downcase thing))
+ ((symbolp thing) (string-downcase (symbol-name thing)))
+ ((and (listp thing) (eq (car thing) :xref-list))
+ (stringify (cdr thing)))
+ ((listp thing) (stringify (car thing)))
+ (t (string thing)))))
+ (dolist (item list-of-trees)
+ (let* ((fname (stringify item))
+ (filename (concatenate 'string directory
+ (string-trim '(#\: #\|) fname)
+ ".ps")))
+ (format t "~&Creating PostScript file ~S." filename)
+ (with-open-file (*standard-output* filename
+ :direction :output
+ :if-does-not-exist :create
+ :if-exists :supersede)
+ ;; Note that the #'eq prints the DAG as a tree. If
+ ;; you replace it with #'equal, it will print it as
+ ;; a DAG, which I think is slightly ugly.
+ (psgraph:psgraph item
+ #'caller-tree-children #'caller-info shrink
+ insert #'eq)))))))
+
+(defun caller-tree-children (tree)
+ (when (and tree (listp tree) (not (eq (car tree) :xref-list)))
+ (cadr tree)))
+
+(defun caller-tree-node (tree)
+ (when tree
+ (cond ((and (listp tree) (eq (car tree) :xref-list))
+ (cdr tree))
+ ((listp tree)
+ (car tree))
+ (t
+ tree))))
+
+(defun caller-info (tree)
+ (let ((node (caller-tree-node tree)))
+ (list node)))
+|#
+#|
+;;; Code to print out graphical trees of CLOS class hierarchies.
+(defun print-class-hierarchy (&optional (start-class 'anything)
+ (file "classes.ps"))
+ (let ((start (find-class start-class)))
+ (when start
+ (with-open-file (*standard-output* file :direction :output)
+ (psgraph:psgraph start
+ #'clos::class-direct-subclasses
+ #'(lambda (x)
+ (list (format nil "~A" (clos::class-name x))))
+ t nil #'eq)))))
+
+|#
+
+
+;;; ****************************************************************
+;;; Cross Referencing Patterns for Common Lisp *********************
+;;; ****************************************************************
+(clear-patterns)
+
+;;; ********************************
+;;; Pattern Substitutions **********
+;;; ********************************
+(define-pattern-substitution integer (:test #'integerp))
+(define-pattern-substitution rational (:test #'rationalp))
+(define-pattern-substitution symbol (:test #'symbolp))
+(define-pattern-substitution string (:test #'stringp))
+(define-pattern-substitution number (:test #'numberp))
+(define-pattern-substitution lambda-list
+ ((:star var)
+ (:optional (:eq &optional)
+ (:star (:or var
+ (var (:optional form (:optional var))))))
+ (:optional (:eq &rest) var)
+ (:optional (:eq &key) (:star (:or var
+ ((:or var
+ (keyword var))
+ (:optional form (:optional var)))))
+ (:optional &allow-other-keys))
+ (:optional (:eq &aux)
+ (:star (:or var
+ (var (:optional form)))))))
+(define-pattern-substitution test form)
+(define-pattern-substitution body
+ ((:star (:or declaration documentation-string))
+ (:star form)))
+(define-pattern-substitution documentation-string string)
+(define-pattern-substitution initial-value form)
+(define-pattern-substitution tag symbol)
+(define-pattern-substitution declaration ((:eq declare)(:rest :ignore)))
+(define-pattern-substitution destination form)
+(define-pattern-substitution control-string string)
+(define-pattern-substitution format-arguments
+ ((:star form)))
+(define-pattern-substitution fn
+ (:or ((:eq quote) function)
+ ((:eq function) function)
+ function))
+
+;;; ********************************
+;;; Caller Patterns ****************
+;;; ********************************
+
+;;; Types Related
+(define-caller-pattern coerce (form :ignore) :lisp)
+(define-caller-pattern type-of (form) :lisp)
+(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2)
+(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2)
+
+;;; Lambdas and Definitions
+(define-variable-pattern lambda-list-keywords :lisp)
+(define-variable-pattern lambda-parameters-limit :lisp)
+(define-caller-pattern lambda (lambda-list (:rest body)) :lisp)
+
+(define-caller-pattern defun
+ (name lambda-list
+ (:star (:or documentation-string declaration))
+ (:star form))
+ :lisp)
+
+;;; perhaps this should use VAR, instead of NAME
+(define-caller-pattern defvar
+ (var (:optional initial-value (:optional documentation-string)))
+ :lisp)
+(define-caller-pattern defparameter
+ (var initial-value (:optional documentation-string))
+ :lisp)
+(define-caller-pattern defconstant
+ (var initial-value (:optional documentation-string))
+ :lisp)
+
+(define-caller-pattern eval-when
+ (:ignore ; the situations
+ (:star form))
+ :lisp)
+
+;;; Logical Values
+(define-variable-pattern nil :lisp)
+(define-variable-pattern t :lisp)
+
+;;; Predicates
+(define-caller-pattern typep (form form) :lisp)
+(define-caller-pattern subtypep (form form) :lisp)
+
+(define-caller-pattern null (form) :lisp)
+(define-caller-pattern symbolp (form) :lisp)
+(define-caller-pattern atom (form) :lisp)
+(define-caller-pattern consp (form) :lisp)
+(define-caller-pattern listp (form) :lisp)
+(define-caller-pattern numberp (form) :lisp)
+(define-caller-pattern integerp (form) :lisp)
+(define-caller-pattern rationalp (form) :lisp)
+(define-caller-pattern floatp (form) :lisp)
+(define-caller-pattern realp (form) :lisp2)
+(define-caller-pattern complexp (form) :lisp)
+(define-caller-pattern characterp (form) :lisp)
+(define-caller-pattern stringp (form) :lisp)
+(define-caller-pattern bit-vector-p (form) :lisp)
+(define-caller-pattern vectorp (form) :lisp)
+(define-caller-pattern simple-vector-p (form) :lisp)
+(define-caller-pattern simple-string-p (form) :lisp)
+(define-caller-pattern simple-bit-vector-p (form) :lisp)
+(define-caller-pattern arrayp (form) :lisp)
+(define-caller-pattern packagep (form) :lisp)
+(define-caller-pattern functionp (form) :lisp)
+(define-caller-pattern compiled-function-p (form) :lisp)
+(define-caller-pattern commonp (form) :lisp)
+
+;;; Equality Predicates
+(define-caller-pattern eq (form form) :lisp)
+(define-caller-pattern eql (form form) :lisp)
+(define-caller-pattern equal (form form) :lisp)
+(define-caller-pattern equalp (form form) :lisp)
+
+;;; Logical Operators
+(define-caller-pattern not (form) :lisp)
+(define-caller-pattern or ((:star form)) :lisp)
+(define-caller-pattern and ((:star form)) :lisp)
+
+;;; Reference
+
+;;; Quote is a problem. In Defmacro & friends, we'd like to actually
+;;; look at the argument, 'cause it hides internal function calls
+;;; of the defmacro.
+(define-caller-pattern quote (:ignore) :lisp)
+
+(define-caller-pattern function ((:or fn form)) :lisp)
+(define-caller-pattern symbol-value (form) :lisp)
+(define-caller-pattern symbol-function (form) :lisp)
+(define-caller-pattern fdefinition (form) :lisp2)
+(define-caller-pattern boundp (form) :lisp)
+(define-caller-pattern fboundp (form) :lisp)
+(define-caller-pattern special-form-p (form) :lisp)
+
+;;; Assignment
+(define-caller-pattern setq ((:star var form)) :lisp)
+(define-caller-pattern psetq ((:star var form)) :lisp)
+(define-caller-pattern set (form form) :lisp)
+(define-caller-pattern makunbound (form) :lisp)
+(define-caller-pattern fmakunbound (form) :lisp)
+
+;;; Generalized Variables
+(define-caller-pattern setf ((:star form form)) :lisp)
+(define-caller-pattern psetf ((:star form form)) :lisp)
+(define-caller-pattern shiftf ((:plus form) form) :lisp)
+(define-caller-pattern rotatef ((:star form)) :lisp)
+(define-caller-pattern define-modify-macro
+ (name
+ lambda-list
+ fn
+ (:optional documentation-string))
+ :lisp)
+(define-caller-pattern defsetf
+ (:or (name name (:optional documentation-string))
+ (name lambda-list (var)
+ (:star (:or declaration documentation-string))
+ (:star form)))
+ :lisp)
+(define-caller-pattern define-setf-method
+ (name lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp)
+(define-caller-pattern get-setf-method (form) :lisp)
+(define-caller-pattern get-setf-method-multiple-value (form) :lisp)
+
+
+;;; Function invocation
+(define-caller-pattern apply (fn form (:star form)) :lisp)
+(define-caller-pattern funcall (fn (:star form)) :lisp)
+
+
+;;; Simple sequencing
+(define-caller-pattern progn ((:star form)) :lisp)
+(define-caller-pattern prog1 (form (:star form)) :lisp)
+(define-caller-pattern prog2 (form form (:star form)) :lisp)
+
+;;; Variable bindings
+(define-caller-pattern let
+ (((:star (:or var (var &optional form))))
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern let*
+ (((:star (:or var (var &optional form))))
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern compiler-let
+ (((:star (:or var (var form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern progv
+ (form form (:star form)) :lisp)
+(define-caller-pattern flet
+ (((:star (name lambda-list
+ (:star (:or declaration
+ documentation-string))
+ (:star form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern labels
+ (((:star (name lambda-list
+ (:star (:or declaration
+ documentation-string))
+ (:star form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern macrolet
+ (((:star (name lambda-list
+ (:star (:or declaration
+ documentation-string))
+ (:star form))))
+ (:star form))
+ :lisp)
+(define-caller-pattern symbol-macrolet
+ (((:star (var form))) (:star declaration) (:star form))
+ :lisp2)
+
+;;; Conditionals
+(define-caller-pattern if (test form (:optional form)) :lisp)
+(define-caller-pattern when (test (:star form)) :lisp)
+(define-caller-pattern unless (test (:star form)) :lisp)
+(define-caller-pattern cond ((:star (test (:star form)))) :lisp)
+(define-caller-pattern case
+ (form
+ (:star ((:or symbol
+ ((:star symbol)))
+ (:star form))))
+ :lisp)
+(define-caller-pattern typecase (form (:star (symbol (:star form))))
+ :lisp)
+
+;;; Blocks and Exits
+(define-caller-pattern block (name (:star form)) :lisp)
+(define-caller-pattern return-from (function (:optional form)) :lisp)
+(define-caller-pattern return ((:optional form)) :lisp)
+
+;;; Iteration
+(define-caller-pattern loop ((:star form)) :lisp)
+(define-caller-pattern do
+ (((:star (:or var
+ (var (:optional form (:optional form)))))) ; init step
+ (form (:star form)) ; end-test result
+ (:star declaration)
+ (:star (:or tag form))) ; statement
+ :lisp)
+(define-caller-pattern do*
+ (((:star (:or var
+ (var (:optional form (:optional form))))))
+ (form (:star form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern dolist
+ ((var form (:optional form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern dotimes
+ ((var form (:optional form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+
+;;; Mapping
+(define-caller-pattern mapcar (fn form (:star form)) :lisp)
+(define-caller-pattern maplist (fn form (:star form)) :lisp)
+(define-caller-pattern mapc (fn form (:star form)) :lisp)
+(define-caller-pattern mapl (fn form (:star form)) :lisp)
+(define-caller-pattern mapcan (fn form (:star form)) :lisp)
+(define-caller-pattern mapcon (fn form (:star form)) :lisp)
+
+;;; The "Program Feature"
+(define-caller-pattern tagbody ((:star (:or tag form))) :lisp)
+(define-caller-pattern prog
+ (((:star (:or var (var (:optional form)))))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern prog*
+ (((:star (:or var (var (:optional form)))))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern go (tag) :lisp)
+
+;;; Multiple Values
+(define-caller-pattern values ((:star form)) :lisp)
+(define-variable-pattern multiple-values-limit :lisp)
+(define-caller-pattern values-list (form) :lisp)
+(define-caller-pattern multiple-value-list (form) :lisp)
+(define-caller-pattern multiple-value-call (fn (:star form)) :lisp)
+(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp)
+(define-caller-pattern multiple-value-bind
+ (((:star var)) form
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp)
+(define-caller-pattern nth-value (form form) :lisp2)
+
+;;; Dynamic Non-Local Exits
+(define-caller-pattern catch (tag (:star form)) :lisp)
+(define-caller-pattern throw (tag form) :lisp)
+(define-caller-pattern unwind-protect (form (:star form)) :lisp)
+
+;;; Macros
+(define-caller-pattern macro-function (form) :lisp)
+(define-caller-pattern defmacro
+ (name
+ lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp)
+(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp)
+(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp)
+(define-variable-pattern *macroexpand-hook* :lisp)
+
+;;; Destructuring
+(define-caller-pattern destructuring-bind
+ (lambda-list form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+
+;;; Compiler Macros
+(define-caller-pattern define-compiler-macro
+ (name lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp2)
+(define-caller-pattern compiler-macro-function (form) :lisp2)
+(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2)
+(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) :lisp2)
+
+;;; Environments
+(define-caller-pattern variable-information (form &optional :ignore)
+ :lisp2)
+(define-caller-pattern function-information (fn &optional :ignore) :lisp2)
+(define-caller-pattern declaration-information (form &optional :ignore) :lisp2)
+(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2)
+(define-caller-pattern define-declaration
+ (name
+ lambda-list
+ (:star form))
+ :lisp2)
+(define-caller-pattern parse-macro (name lambda-list form) :lisp2)
+(define-caller-pattern enclose (form &optional :ignore) :lisp2)
+
+
+;;; Declarations
+(define-caller-pattern declare ((:rest :ignore)) :lisp)
+(define-caller-pattern proclaim ((:rest :ignore)) :lisp)
+(define-caller-pattern locally ((:star declaration) (:star form)) :lisp)
+(define-caller-pattern declaim ((:rest :ignore)) :lisp2)
+(define-caller-pattern the (form form) :lisp)
+
+;;; Symbols
+(define-caller-pattern get (form form (:optional form)) :lisp)
+(define-caller-pattern remprop (form form) :lisp)
+(define-caller-pattern symbol-plist (form) :lisp)
+(define-caller-pattern getf (form form (:optional form)) :lisp)
+(define-caller-pattern remf (form form) :lisp)
+(define-caller-pattern get-properties (form form) :lisp)
+
+(define-caller-pattern symbol-name (form) :lisp)
+(define-caller-pattern make-symbol (form) :lisp)
+(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp)
+(define-caller-pattern gensym ((:optional :ignore)) :lisp)
+(define-variable-pattern *gensym-counter* :lisp2)
+(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp)
+(define-caller-pattern symbol-package (form) :lisp)
+(define-caller-pattern keywordp (form) :lisp)
+
+;;; Packages
+(define-variable-pattern *package* :lisp)
+(define-caller-pattern make-package ((:rest :ignore)) :lisp)
+(define-caller-pattern in-package ((:rest :ignore)) :lisp)
+(define-caller-pattern find-package ((:rest :ignore)) :lisp)
+(define-caller-pattern package-name ((:rest :ignore)) :lisp)
+(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp)
+(define-caller-pattern rename-package ((:rest :ignore)) :lisp)
+(define-caller-pattern package-use-list ((:rest :ignore)) :lisp)
+(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp)
+(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp)
+(define-caller-pattern list-all-packages () :lisp)
+(define-caller-pattern delete-package ((:rest :ignore)) :lisp2)
+(define-caller-pattern intern (form &optional :ignore) :lisp)
+(define-caller-pattern find-symbol (form &optional :ignore) :lisp)
+(define-caller-pattern unintern (form &optional :ignore) :lisp)
+
+(define-caller-pattern export ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern unexport ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern import ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern shadowing-import ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+(define-caller-pattern shadow ((:or symbol ((:star symbol)))
+ &optional :ignore) :lisp)
+
+(define-caller-pattern use-package ((:rest :ignore)) :lisp)
+(define-caller-pattern unuse-package ((:rest :ignore)) :lisp)
+(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2)
+(define-caller-pattern find-all-symbols (form) :lisp)
+(define-caller-pattern do-symbols
+ ((var (:optional form (:optional form)))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern do-external-symbols
+ ((var (:optional form (:optional form)))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern do-all-symbols
+ ((var (:optional form))
+ (:star declaration)
+ (:star (:or tag form)))
+ :lisp)
+(define-caller-pattern with-package-iterator
+ ((name form (:plus :ignore))
+ (:star form))
+ :lisp2)
+
+;;; Modules
+(define-variable-pattern *modules* :lisp)
+(define-caller-pattern provide (form) :lisp)
+(define-caller-pattern require (form &optional :ignore) :lisp)
+
+
+;;; Numbers
+(define-caller-pattern zerop (form) :lisp)
+(define-caller-pattern plusp (form) :lisp)
+(define-caller-pattern minusp (form) :lisp)
+(define-caller-pattern oddp (form) :lisp)
+(define-caller-pattern evenp (form) :lisp)
+
+(define-caller-pattern = (form (:star form)) :lisp)
+(define-caller-pattern /= (form (:star form)) :lisp)
+(define-caller-pattern > (form (:star form)) :lisp)
+(define-caller-pattern < (form (:star form)) :lisp)
+(define-caller-pattern <= (form (:star form)) :lisp)
+(define-caller-pattern >= (form (:star form)) :lisp)
+
+(define-caller-pattern max (form (:star form)) :lisp)
+(define-caller-pattern min (form (:star form)) :lisp)
+
+(define-caller-pattern - (form (:star form)) :lisp)
+(define-caller-pattern + (form (:star form)) :lisp)
+(define-caller-pattern * (form (:star form)) :lisp)
+(define-caller-pattern / (form (:star form)) :lisp)
+(define-caller-pattern 1+ (form) :lisp)
+(define-caller-pattern 1- (form) :lisp)
+
+(define-caller-pattern incf (form form) :lisp)
+(define-caller-pattern decf (form form) :lisp)
+
+(define-caller-pattern conjugate (form) :lisp)
+
+(define-caller-pattern gcd ((:star form)) :lisp)
+(define-caller-pattern lcm ((:star form)) :lisp)
+
+(define-caller-pattern exp (form) :lisp)
+(define-caller-pattern expt (form form) :lisp)
+(define-caller-pattern log (form (:optional form)) :lisp)
+(define-caller-pattern sqrt (form) :lisp)
+(define-caller-pattern isqrt (form) :lisp)
+
+(define-caller-pattern abs (form) :lisp)
+(define-caller-pattern phase (form) :lisp)
+(define-caller-pattern signum (form) :lisp)
+(define-caller-pattern sin (form) :lisp)
+(define-caller-pattern cos (form) :lisp)
+(define-caller-pattern tan (form) :lisp)
+(define-caller-pattern cis (form) :lisp)
+(define-caller-pattern asin (form) :lisp)
+(define-caller-pattern acos (form) :lisp)
+(define-caller-pattern atan (form &optional form) :lisp)
+(define-variable-pattern pi :lisp)
+
+(define-caller-pattern sinh (form) :lisp)
+(define-caller-pattern cosh (form) :lisp)
+(define-caller-pattern tanh (form) :lisp)
+(define-caller-pattern asinh (form) :lisp)
+(define-caller-pattern acosh (form) :lisp)
+(define-caller-pattern atanh (form) :lisp)
+
+;;; Type Conversions and Extractions
+(define-caller-pattern float (form (:optional form)) :lisp)
+(define-caller-pattern rational (form) :lisp)
+(define-caller-pattern rationalize (form) :lisp)
+(define-caller-pattern numerator (form) :lisp)
+(define-caller-pattern denominator (form) :lisp)
+
+(define-caller-pattern floor (form (:optional form)) :lisp)
+(define-caller-pattern ceiling (form (:optional form)) :lisp)
+(define-caller-pattern truncate (form (:optional form)) :lisp)
+(define-caller-pattern round (form (:optional form)) :lisp)
+
+(define-caller-pattern mod (form form) :lisp)
+(define-caller-pattern rem (form form) :lisp)
+
+(define-caller-pattern ffloor (form (:optional form)) :lisp)
+(define-caller-pattern fceiling (form (:optional form)) :lisp)
+(define-caller-pattern ftruncate (form (:optional form)) :lisp)
+(define-caller-pattern fround (form (:optional form)) :lisp)
+
+(define-caller-pattern decode-float (form) :lisp)
+(define-caller-pattern scale-float (form form) :lisp)
+(define-caller-pattern float-radix (form) :lisp)
+(define-caller-pattern float-sign (form (:optional form)) :lisp)
+(define-caller-pattern float-digits (form) :lisp)
+(define-caller-pattern float-precision (form) :lisp)
+(define-caller-pattern integer-decode-float (form) :lisp)
+
+(define-caller-pattern complex (form (:optional form)) :lisp)
+(define-caller-pattern realpart (form) :lisp)
+(define-caller-pattern imagpart (form) :lisp)
+
+(define-caller-pattern logior ((:star form)) :lisp)
+(define-caller-pattern logxor ((:star form)) :lisp)
+(define-caller-pattern logand ((:star form)) :lisp)
+(define-caller-pattern logeqv ((:star form)) :lisp)
+
+(define-caller-pattern lognand (form form) :lisp)
+(define-caller-pattern lognor (form form) :lisp)
+(define-caller-pattern logandc1 (form form) :lisp)
+(define-caller-pattern logandc2 (form form) :lisp)
+(define-caller-pattern logorc1 (form form) :lisp)
+(define-caller-pattern logorc2 (form form) :lisp)
+
+(define-caller-pattern boole (form form form) :lisp)
+(define-variable-pattern boole-clr :lisp)
+(define-variable-pattern boole-set :lisp)
+(define-variable-pattern boole-1 :lisp)
+(define-variable-pattern boole-2 :lisp)
+(define-variable-pattern boole-c1 :lisp)
+(define-variable-pattern boole-c2 :lisp)
+(define-variable-pattern boole-and :lisp)
+(define-variable-pattern boole-ior :lisp)
+(define-variable-pattern boole-xor :lisp)
+(define-variable-pattern boole-eqv :lisp)
+(define-variable-pattern boole-nand :lisp)
+(define-variable-pattern boole-nor :lisp)
+(define-variable-pattern boole-andc1 :lisp)
+(define-variable-pattern boole-andc2 :lisp)
+(define-variable-pattern boole-orc1 :lisp)
+(define-variable-pattern boole-orc2 :lisp)
+
+(define-caller-pattern lognot (form) :lisp)
+(define-caller-pattern logtest (form form) :lisp)
+(define-caller-pattern logbitp (form form) :lisp)
+(define-caller-pattern ash (form form) :lisp)
+(define-caller-pattern logcount (form) :lisp)
+(define-caller-pattern integer-length (form) :lisp)
+
+(define-caller-pattern byte (form form) :lisp)
+(define-caller-pattern byte-size (form) :lisp)
+(define-caller-pattern byte-position (form) :lisp)
+(define-caller-pattern ldb (form form) :lisp)
+(define-caller-pattern ldb-test (form form) :lisp)
+(define-caller-pattern mask-field (form form) :lisp)
+(define-caller-pattern dpb (form form form) :lisp)
+(define-caller-pattern deposit-field (form form form) :lisp)
+
+;;; Random Numbers
+(define-caller-pattern random (form (:optional form)) :lisp)
+(define-variable-pattern *random-state* :lisp)
+(define-caller-pattern make-random-state ((:optional form)) :lisp)
+(define-caller-pattern random-state-p (form) :lisp)
+
+;;; Implementation Parameters
+(define-variable-pattern most-positive-fixnum :lisp)
+(define-variable-pattern most-negative-fixnum :lisp)
+(define-variable-pattern most-positive-short-float :lisp)
+(define-variable-pattern least-positive-short-float :lisp)
+(define-variable-pattern least-negative-short-float :lisp)
+(define-variable-pattern most-negative-short-float :lisp)
+(define-variable-pattern most-positive-single-float :lisp)
+(define-variable-pattern least-positive-single-float :lisp)
+(define-variable-pattern least-negative-single-float :lisp)
+(define-variable-pattern most-negative-single-float :lisp)
+(define-variable-pattern most-positive-double-float :lisp)
+(define-variable-pattern least-positive-double-float :lisp)
+(define-variable-pattern least-negative-double-float :lisp)
+(define-variable-pattern most-negative-double-float :lisp)
+(define-variable-pattern most-positive-long-float :lisp)
+(define-variable-pattern least-positive-long-float :lisp)
+(define-variable-pattern least-negative-long-float :lisp)
+(define-variable-pattern most-negative-long-float :lisp)
+(define-variable-pattern least-positive-normalized-short-float :lisp2)
+(define-variable-pattern least-negative-normalized-short-float :lisp2)
+(define-variable-pattern least-positive-normalized-single-float :lisp2)
+(define-variable-pattern least-negative-normalized-single-float :lisp2)
+(define-variable-pattern least-positive-normalized-double-float :lisp2)
+(define-variable-pattern least-negative-normalized-double-float :lisp2)
+(define-variable-pattern least-positive-normalized-long-float :lisp2)
+(define-variable-pattern least-negative-normalized-long-float :lisp2)
+(define-variable-pattern short-float-epsilon :lisp)
+(define-variable-pattern single-float-epsilon :lisp)
+(define-variable-pattern double-float-epsilon :lisp)
+(define-variable-pattern long-float-epsilon :lisp)
+(define-variable-pattern short-float-negative-epsilon :lisp)
+(define-variable-pattern single-float-negative-epsilon :lisp)
+(define-variable-pattern double-float-negative-epsilon :lisp)
+(define-variable-pattern long-float-negative-epsilon :lisp)
+
+;;; Characters
+(define-variable-pattern char-code-limit :lisp)
+(define-variable-pattern char-font-limit :lisp)
+(define-variable-pattern char-bits-limit :lisp)
+(define-caller-pattern standard-char-p (form) :lisp)
+(define-caller-pattern graphic-char-p (form) :lisp)
+(define-caller-pattern string-char-p (form) :lisp)
+(define-caller-pattern alpha-char-p (form) :lisp)
+(define-caller-pattern upper-case-p (form) :lisp)
+(define-caller-pattern lower-case-p (form) :lisp)
+(define-caller-pattern both-case-p (form) :lisp)
+(define-caller-pattern digit-char-p (form (:optional form)) :lisp)
+(define-caller-pattern alphanumericp (form) :lisp)
+
+(define-caller-pattern char= ((:star form)) :lisp)
+(define-caller-pattern char/= ((:star form)) :lisp)
+(define-caller-pattern char< ((:star form)) :lisp)
+(define-caller-pattern char> ((:star form)) :lisp)
+(define-caller-pattern char<= ((:star form)) :lisp)
+(define-caller-pattern char>= ((:star form)) :lisp)
+
+(define-caller-pattern char-equal ((:star form)) :lisp)
+(define-caller-pattern char-not-equal ((:star form)) :lisp)
+(define-caller-pattern char-lessp ((:star form)) :lisp)
+(define-caller-pattern char-greaterp ((:star form)) :lisp)
+(define-caller-pattern char-not-greaterp ((:star form)) :lisp)
+(define-caller-pattern char-not-lessp ((:star form)) :lisp)
+
+(define-caller-pattern char-code (form) :lisp)
+(define-caller-pattern char-bits (form) :lisp)
+(define-caller-pattern char-font (form) :lisp)
+(define-caller-pattern code-char (form (:optional form form)) :lisp)
+(define-caller-pattern make-char (form (:optional form form)) :lisp)
+(define-caller-pattern characterp (form) :lisp)
+(define-caller-pattern char-upcase (form) :lisp)
+(define-caller-pattern char-downcase (form) :lisp)
+(define-caller-pattern digit-char (form (:optional form form)) :lisp)
+(define-caller-pattern char-int (form) :lisp)
+(define-caller-pattern int-char (form) :lisp)
+(define-caller-pattern char-name (form) :lisp)
+(define-caller-pattern name-char (form) :lisp)
+(define-variable-pattern char-control-bit :lisp)
+(define-variable-pattern char-meta-bit :lisp)
+(define-variable-pattern char-super-bit :lisp)
+(define-variable-pattern char-hyper-bit :lisp)
+(define-caller-pattern char-bit (form form) :lisp)
+(define-caller-pattern set-char-bit (form form form) :lisp)
+
+;;; Sequences
+(define-caller-pattern complement (fn) :lisp2)
+(define-caller-pattern elt (form form) :lisp)
+(define-caller-pattern subseq (form form &optional form) :lisp)
+(define-caller-pattern copy-seq (form) :lisp)
+(define-caller-pattern length (form) :lisp)
+(define-caller-pattern reverse (form) :lisp)
+(define-caller-pattern nreverse (form) :lisp)
+(define-caller-pattern make-sequence (form form &key form) :lisp)
+
+(define-caller-pattern concatenate (form (:star form)) :lisp)
+(define-caller-pattern map (form fn form (:star form)) :lisp)
+(define-caller-pattern map-into (form fn (:star form)) :lisp2)
+
+(define-caller-pattern some (fn form (:star form)) :lisp)
+(define-caller-pattern every (fn form (:star form)) :lisp)
+(define-caller-pattern notany (fn form (:star form)) :lisp)
+(define-caller-pattern notevery (fn form (:star form)) :lisp)
+
+(define-caller-pattern reduce (fn form &key (:star form)) :lisp)
+(define-caller-pattern fill (form form &key (:star form)) :lisp)
+(define-caller-pattern replace (form form &key (:star form)) :lisp)
+(define-caller-pattern remove (form form &key (:star form)) :lisp)
+(define-caller-pattern remove-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern delete (form form &key (:star form)) :lisp)
+(define-caller-pattern delete-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp)
+(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp)
+(define-caller-pattern substitute (form form form &key (:star form)) :lisp)
+(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern substitute-if-not (form fn form &key (:star form)) :lisp)
+(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp)
+(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) :lisp)
+(define-caller-pattern find (form form &key (:star form)) :lisp)
+(define-caller-pattern find-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern position (form form &key (:star form)) :lisp)
+(define-caller-pattern position-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern count (form form &key (:star form)) :lisp)
+(define-caller-pattern count-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp)
+(define-caller-pattern mismatch (form form &key (:star form)) :lisp)
+(define-caller-pattern search (form form &key (:star form)) :lisp)
+(define-caller-pattern sort (form fn &key (:star form)) :lisp)
+(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp)
+(define-caller-pattern merge (form form form fn &key (:star form)) :lisp)
+
+;;; Lists
+(define-caller-pattern car (form) :lisp)
+(define-caller-pattern cdr (form) :lisp)
+(define-caller-pattern caar (form) :lisp)
+(define-caller-pattern cadr (form) :lisp)
+(define-caller-pattern cdar (form) :lisp)
+(define-caller-pattern cddr (form) :lisp)
+(define-caller-pattern caaar (form) :lisp)
+(define-caller-pattern caadr (form) :lisp)
+(define-caller-pattern cadar (form) :lisp)
+(define-caller-pattern caddr (form) :lisp)
+(define-caller-pattern cdaar (form) :lisp)
+(define-caller-pattern cdadr (form) :lisp)
+(define-caller-pattern cddar (form) :lisp)
+(define-caller-pattern cdddr (form) :lisp)
+(define-caller-pattern caaaar (form) :lisp)
+(define-caller-pattern caaadr (form) :lisp)
+(define-caller-pattern caadar (form) :lisp)
+(define-caller-pattern caaddr (form) :lisp)
+(define-caller-pattern cadaar (form) :lisp)
+(define-caller-pattern cadadr (form) :lisp)
+(define-caller-pattern caddar (form) :lisp)
+(define-caller-pattern cadddr (form) :lisp)
+(define-caller-pattern cdaaar (form) :lisp)
+(define-caller-pattern cdaadr (form) :lisp)
+(define-caller-pattern cdadar (form) :lisp)
+(define-caller-pattern cdaddr (form) :lisp)
+(define-caller-pattern cddaar (form) :lisp)
+(define-caller-pattern cddadr (form) :lisp)
+(define-caller-pattern cdddar (form) :lisp)
+(define-caller-pattern cddddr (form) :lisp)
+
+(define-caller-pattern cons (form form) :lisp)
+(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp)
+(define-caller-pattern endp (form) :lisp)
+(define-caller-pattern list-length (form) :lisp)
+(define-caller-pattern nth (form form) :lisp)
+
+(define-caller-pattern first (form) :lisp)
+(define-caller-pattern second (form) :lisp)
+(define-caller-pattern third (form) :lisp)
+(define-caller-pattern fourth (form) :lisp)
+(define-caller-pattern fifth (form) :lisp)
+(define-caller-pattern sixth (form) :lisp)
+(define-caller-pattern seventh (form) :lisp)
+(define-caller-pattern eighth (form) :lisp)
+(define-caller-pattern ninth (form) :lisp)
+(define-caller-pattern tenth (form) :lisp)
+
+(define-caller-pattern rest (form) :lisp)
+(define-caller-pattern nthcdr (form form) :lisp)
+(define-caller-pattern last (form (:optional form)) :lisp)
+(define-caller-pattern list ((:star form)) :lisp)
+(define-caller-pattern list* ((:star form)) :lisp)
+(define-caller-pattern make-list (form &key (:star form)) :lisp)
+(define-caller-pattern append ((:star form)) :lisp)
+(define-caller-pattern copy-list (form) :lisp)
+(define-caller-pattern copy-alist (form) :lisp)
+(define-caller-pattern copy-tree (form) :lisp)
+(define-caller-pattern revappend (form form) :lisp)
+(define-caller-pattern nconc ((:star form)) :lisp)
+(define-caller-pattern nreconc (form form) :lisp)
+(define-caller-pattern push (form form) :lisp)
+(define-caller-pattern pushnew (form form &key (:star form)) :lisp)
+(define-caller-pattern pop (form) :lisp)
+(define-caller-pattern butlast (form (:optional form)) :lisp)
+(define-caller-pattern nbutlast (form (:optional form)) :lisp)
+(define-caller-pattern ldiff (form form) :lisp)
+(define-caller-pattern rplaca (form form) :lisp)
+(define-caller-pattern rplacd (form form) :lisp)
+
+(define-caller-pattern subst (form form form &key (:star form)) :lisp)
+(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp)
+(define-caller-pattern nsubst (form form form &key (:star form)) :lisp)
+(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp)
+(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp)
+(define-caller-pattern sublis (form form &key (:star form)) :lisp)
+(define-caller-pattern nsublis (form form &key (:star form)) :lisp)
+(define-caller-pattern member (form form &key (:star form)) :lisp)
+(define-caller-pattern member-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp)
+
+(define-caller-pattern tailp (form form) :lisp)
+(define-caller-pattern adjoin (form form &key (:star form)) :lisp)
+(define-caller-pattern union (form form &key (:star form)) :lisp)
+(define-caller-pattern nunion (form form &key (:star form)) :lisp)
+(define-caller-pattern intersection (form form &key (:star form)) :lisp)
+(define-caller-pattern nintersection (form form &key (:star form)) :lisp)
+(define-caller-pattern set-difference (form form &key (:star form)) :lisp)
+(define-caller-pattern nset-difference (form form &key (:star form)) :lisp)
+(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp)
+(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp)
+(define-caller-pattern subsetp (form form &key (:star form)) :lisp)
+
+(define-caller-pattern acons (form form form) :lisp)
+(define-caller-pattern pairlis (form form (:optional form)) :lisp)
+(define-caller-pattern assoc (form form &key (:star form)) :lisp)
+(define-caller-pattern assoc-if (fn form) :lisp)
+(define-caller-pattern assoc-if-not (fn form) :lisp)
+(define-caller-pattern rassoc (form form &key (:star form)) :lisp)
+(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp)
+(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp)
+
+;;; Hash Tables
+(define-caller-pattern make-hash-table (&key (:star form)) :lisp)
+(define-caller-pattern hash-table-p (form) :lisp)
+(define-caller-pattern gethash (form form (:optional form)) :lisp)
+(define-caller-pattern remhash (form form) :lisp)
+(define-caller-pattern maphash (fn form) :lisp)
+(define-caller-pattern clrhash (form) :lisp)
+(define-caller-pattern hash-table-count (form) :lisp)
+(define-caller-pattern with-hash-table-iterator
+ ((name form) (:star form)) :lisp2)
+(define-caller-pattern hash-table-rehash-size (form) :lisp2)
+(define-caller-pattern hash-table-rehash-threshold (form) :lisp2)
+(define-caller-pattern hash-table-size (form) :lisp2)
+(define-caller-pattern hash-table-test (form) :lisp2)
+(define-caller-pattern sxhash (form) :lisp)
+
+;;; Arrays
+(define-caller-pattern make-array (form &key (:star form)) :lisp)
+(define-variable-pattern array-rank-limit :lisp)
+(define-variable-pattern array-dimension-limit :lisp)
+(define-variable-pattern array-total-size-limit :lisp)
+(define-caller-pattern vector ((:star form)) :lisp)
+(define-caller-pattern aref (form (:star form)) :lisp)
+(define-caller-pattern svref (form form) :lisp)
+(define-caller-pattern array-element-type (form) :lisp)
+(define-caller-pattern array-rank (form) :lisp)
+(define-caller-pattern array-dimension (form form) :lisp)
+(define-caller-pattern array-dimensions (form) :lisp)
+(define-caller-pattern array-total-size (form) :lisp)
+(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp)
+(define-caller-pattern array-row-major-index (form (:star form)) :lisp)
+(define-caller-pattern row-major-aref (form form) :lisp2)
+(define-caller-pattern adjustable-array-p (form) :lisp)
+
+(define-caller-pattern bit (form (:star form)) :lisp)
+(define-caller-pattern sbit (form (:star form)) :lisp)
+
+(define-caller-pattern bit-and (form form (:optional form)) :lisp)
+(define-caller-pattern bit-ior (form form (:optional form)) :lisp)
+(define-caller-pattern bit-xor (form form (:optional form)) :lisp)
+(define-caller-pattern bit-eqv (form form (:optional form)) :lisp)
+(define-caller-pattern bit-nand (form form (:optional form)) :lisp)
+(define-caller-pattern bit-nor (form form (:optional form)) :lisp)
+(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp)
+(define-caller-pattern bit-not (form (:optional form)) :lisp)
+
+(define-caller-pattern array-has-fill-pointer-p (form) :lisp)
+(define-caller-pattern fill-pointer (form) :lisp)
+(define-caller-pattern vector-push (form form) :lisp)
+(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp)
+(define-caller-pattern vector-pop (form) :lisp)
+(define-caller-pattern adjust-array (form form &key (:star form)) :lisp)
+
+;;; Strings
+(define-caller-pattern char (form form) :lisp)
+(define-caller-pattern schar (form form) :lisp)
+(define-caller-pattern string= (form form &key (:star form)) :lisp)
+(define-caller-pattern string-equal (form form &key (:star form)) :lisp)
+(define-caller-pattern string< (form form &key (:star form)) :lisp)
+(define-caller-pattern string> (form form &key (:star form)) :lisp)
+(define-caller-pattern string<= (form form &key (:star form)) :lisp)
+(define-caller-pattern string>= (form form &key (:star form)) :lisp)
+(define-caller-pattern string/= (form form &key (:star form)) :lisp)
+(define-caller-pattern string-lessp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp)
+(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp)
+
+(define-caller-pattern make-string (form &key (:star form)) :lisp)
+(define-caller-pattern string-trim (form form) :lisp)
+(define-caller-pattern string-left-trim (form form) :lisp)
+(define-caller-pattern string-right-trim (form form) :lisp)
+(define-caller-pattern string-upcase (form &key (:star form)) :lisp)
+(define-caller-pattern string-downcase (form &key (:star form)) :lisp)
+(define-caller-pattern string-capitalize (form &key (:star form)) :lisp)
+(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp)
+(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp)
+(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp)
+(define-caller-pattern string (form) :lisp)
+
+;;; Structures
+(define-caller-pattern defstruct
+ ((:or name (name (:rest :ignore)))
+ (:optional documentation-string)
+ (:plus :ignore))
+ :lisp)
+
+;;; The Evaluator
+(define-caller-pattern eval (form) :lisp)
+(define-variable-pattern *evalhook* :lisp)
+(define-variable-pattern *applyhook* :lisp)
+(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp)
+(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp)
+(define-caller-pattern constantp (form) :lisp)
+
+;;; Streams
+(define-variable-pattern *standard-input* :lisp)
+(define-variable-pattern *standard-output* :lisp)
+(define-variable-pattern *error-output* :lisp)
+(define-variable-pattern *query-io* :lisp)
+(define-variable-pattern *debug-io* :lisp)
+(define-variable-pattern *terminal-io* :lisp)
+(define-variable-pattern *trace-output* :lisp)
+(define-caller-pattern make-synonym-stream (symbol) :lisp)
+(define-caller-pattern make-broadcast-stream ((:star form)) :lisp)
+(define-caller-pattern make-concatenated-stream ((:star form)) :lisp)
+(define-caller-pattern make-two-way-stream (form form) :lisp)
+(define-caller-pattern make-echo-stream (form form) :lisp)
+(define-caller-pattern make-string-input-stream (form &optional form form) :lisp)
+(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp)
+(define-caller-pattern get-output-stream-string (form) :lisp)
+
+(define-caller-pattern with-open-stream
+ ((var form)
+ (:star declaration)
+ (:star form))
+ :lisp)
+
+(define-caller-pattern with-input-from-string
+ ((var form &key (:star form))
+ (:star declaration)
+ (:star form))
+ :lisp)
+
+(define-caller-pattern with-output-to-string
+ ((var (:optional form))
+ (:star declaration)
+ (:star form))
+ :lisp)
+(define-caller-pattern streamp (form) :lisp)
+(define-caller-pattern open-stream-p (form) :lisp2)
+(define-caller-pattern input-stream-p (form) :lisp)
+(define-caller-pattern output-stream-p (form) :lisp)
+(define-caller-pattern stream-element-type (form) :lisp)
+(define-caller-pattern close (form (:rest :ignore)) :lisp)
+(define-caller-pattern broadcast-stream-streams (form) :lisp2)
+(define-caller-pattern concatenated-stream-streams (form) :lisp2)
+(define-caller-pattern echo-stream-input-stream (form) :lisp2)
+(define-caller-pattern echo-stream-output-stream (form) :lisp2)
+(define-caller-pattern synonym-stream-symbol (form) :lisp2)
+(define-caller-pattern two-way-stream-input-stream (form) :lisp2)
+(define-caller-pattern two-way-stream-output-stream (form) :lisp2)
+(define-caller-pattern interactive-stream-p (form) :lisp2)
+(define-caller-pattern stream-external-format (form) :lisp2)
+
+;;; Reader
+(define-variable-pattern *read-base* :lisp)
+(define-variable-pattern *read-suppress* :lisp)
+(define-variable-pattern *read-eval* :lisp2)
+(define-variable-pattern *readtable* :lisp)
+(define-caller-pattern copy-readtable (&optional form form) :lisp)
+(define-caller-pattern readtablep (form) :lisp)
+(define-caller-pattern set-syntax-from-char (form form &optional form form) :lisp)
+(define-caller-pattern set-macro-character (form fn &optional form) :lisp)
+(define-caller-pattern get-macro-character (form (:optional form)) :lisp)
+(define-caller-pattern make-dispatch-macro-character (form &optional form form)
+ :lisp)
+(define-caller-pattern set-dispatch-macro-character
+ (form form fn (:optional form)) :lisp)
+(define-caller-pattern get-dispatch-macro-character
+ (form form (:optional form)) :lisp)
+(define-caller-pattern readtable-case (form) :lisp2)
+(define-variable-pattern *print-readably* :lisp2)
+(define-variable-pattern *print-escape* :lisp)
+(define-variable-pattern *print-pretty* :lisp)
+(define-variable-pattern *print-circle* :lisp)
+(define-variable-pattern *print-base* :lisp)
+(define-variable-pattern *print-radix* :lisp)
+(define-variable-pattern *print-case* :lisp)
+(define-variable-pattern *print-gensym* :lisp)
+(define-variable-pattern *print-level* :lisp)
+(define-variable-pattern *print-length* :lisp)
+(define-variable-pattern *print-array* :lisp)
+(define-caller-pattern with-standard-io-syntax
+ ((:star declaration)
+ (:star form))
+ :lisp2)
+
+(define-caller-pattern read (&optional form form form form) :lisp)
+(define-variable-pattern *read-default-float-format* :lisp)
+(define-caller-pattern read-preserving-whitespace
+ (&optional form form form form) :lisp)
+(define-caller-pattern read-delimited-list (form &optional form form) :lisp)
+(define-caller-pattern read-line (&optional form form form form) :lisp)
+(define-caller-pattern read-char (&optional form form form form) :lisp)
+(define-caller-pattern unread-char (form (:optional form)) :lisp)
+(define-caller-pattern peek-char (&optional form form form form) :lisp)
+(define-caller-pattern listen ((:optional form)) :lisp)
+(define-caller-pattern read-char-no-hang ((:star form)) :lisp)
+(define-caller-pattern clear-input ((:optional form)) :lisp)
+(define-caller-pattern read-from-string (form (:star form)) :lisp)
+(define-caller-pattern parse-integer (form &rest :ignore) :lisp)
+(define-caller-pattern read-byte ((:star form)) :lisp)
+
+(define-caller-pattern write (form &key (:star form)) :lisp)
+(define-caller-pattern prin1 (form (:optional form)) :lisp)
+(define-caller-pattern print (form (:optional form)) :lisp)
+(define-caller-pattern pprint (form (:optional form)) :lisp)
+(define-caller-pattern princ (form (:optional form)) :lisp)
+(define-caller-pattern write-to-string (form &key (:star form)) :lisp)
+(define-caller-pattern prin1-to-string (form) :lisp)
+(define-caller-pattern princ-to-string (form) :lisp)
+(define-caller-pattern write-char (form (:optional form)) :lisp)
+(define-caller-pattern write-string (form &optional form &key (:star form)) :lisp)
+(define-caller-pattern write-line (form &optional form &key (:star form)) :lisp)
+(define-caller-pattern terpri ((:optional form)) :lisp)
+(define-caller-pattern fresh-line ((:optional form)) :lisp)
+(define-caller-pattern finish-output ((:optional form)) :lisp)
+(define-caller-pattern force-output ((:optional form)) :lisp)
+(define-caller-pattern clear-output ((:optional form)) :lisp)
+(define-caller-pattern print-unreadable-object
+ ((form form &key (:star form))
+ (:star declaration)
+ (:star form))
+ :lisp2)
+(define-caller-pattern write-byte (form form) :lisp)
+(define-caller-pattern format
+ (destination
+ control-string
+ (:rest format-arguments))
+ :lisp)
+
+(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp)
+(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp)
+
+;;; Pathnames
+(define-caller-pattern wild-pathname-p (form &optional form) :lisp2)
+(define-caller-pattern pathname-match-p (form form) :lisp2)
+(define-caller-pattern translate-pathname (form form form &key (:star form))
+ :lisp2)
+
+(define-caller-pattern logical-pathname (form) :lisp2)
+(define-caller-pattern translate-logical-pathname (form &key (:star form)) :lisp2)
+(define-caller-pattern logical-pathname-translations (form) :lisp2)
+(define-caller-pattern load-logical-pathname-translations (form) :lisp2)
+(define-caller-pattern compile-file-pathname (form &key form) :lisp2)
+
+(define-caller-pattern pathname (form) :lisp)
+(define-caller-pattern truename (form) :lisp)
+(define-caller-pattern parse-namestring ((:star form)) :lisp)
+(define-caller-pattern merge-pathnames ((:star form)) :lisp)
+(define-variable-pattern *default-pathname-defaults* :lisp)
+(define-caller-pattern make-pathname ((:star form)) :lisp)
+(define-caller-pattern pathnamep (form) :lisp)
+(define-caller-pattern pathname-host (form) :lisp)
+(define-caller-pattern pathname-device (form) :lisp)
+(define-caller-pattern pathname-directory (form) :lisp)
+(define-caller-pattern pathname-name (form) :lisp)
+(define-caller-pattern pathname-type (form) :lisp)
+(define-caller-pattern pathname-version (form) :lisp)
+(define-caller-pattern namestring (form) :lisp)
+(define-caller-pattern file-namestring (form) :lisp)
+(define-caller-pattern directory-namestring (form) :lisp)
+(define-caller-pattern host-namestring (form) :lisp)
+(define-caller-pattern enough-namestring (form (:optional form)) :lisp)
+(define-caller-pattern user-homedir-pathname (&optional form) :lisp)
+(define-caller-pattern open (form &key (:star form)) :lisp)
+(define-caller-pattern with-open-file
+ ((var form (:rest :ignore))
+ (:star declaration)
+ (:star form))
+ :lisp)
+
+(define-caller-pattern rename-file (form form) :lisp)
+(define-caller-pattern delete-file (form) :lisp)
+(define-caller-pattern probe-file (form) :lisp)
+(define-caller-pattern file-write-date (form) :lisp)
+(define-caller-pattern file-author (form) :lisp)
+(define-caller-pattern file-position (form (:optional form)) :lisp)
+(define-caller-pattern file-length (form) :lisp)
+(define-caller-pattern file-string-length (form form) :lisp2)
+(define-caller-pattern load (form &key (:star form)) :lisp)
+(define-variable-pattern *load-verbose* :lisp)
+(define-variable-pattern *load-print* :lisp2)
+(define-variable-pattern *load-pathname* :lisp2)
+(define-variable-pattern *load-truename* :lisp2)
+(define-caller-pattern make-load-form (form) :lisp2)
+(define-caller-pattern make-load-form-saving-slots (form &optional form)
+ :lisp2)
+(define-caller-pattern directory (form &key (:star form)) :lisp)
+
+;;; Errors
+(define-caller-pattern error (form (:star form)) :lisp)
+(define-caller-pattern cerror (form form (:star form)) :lisp)
+(define-caller-pattern warn (form (:star form)) :lisp)
+(define-variable-pattern *break-on-warnings* :lisp)
+(define-caller-pattern break (&optional form (:star form)) :lisp)
+(define-caller-pattern check-type (form form (:optional form)) :lisp)
+(define-caller-pattern assert
+ (form
+ (:optional ((:star var))
+ (:optional form (:star form))))
+ :lisp)
+(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp)
+(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp)
+(define-caller-pattern ecase
+ (form
+ (:star ((:or symbol ((:star symbol)))
+ (:star form))))
+ :lisp)
+(define-caller-pattern ccase
+ (form
+ (:star ((:or symbol ((:star symbol)))
+ (:star form))))
+ :lisp)
+
+;;; The Compiler
+(define-caller-pattern compile (form (:optional form)) :lisp)
+(define-caller-pattern compile-file (form &key (:star form)) :lisp)
+(define-variable-pattern *compile-verbose* :lisp2)
+(define-variable-pattern *compile-print* :lisp2)
+(define-variable-pattern *compile-file-pathname* :lisp2)
+(define-variable-pattern *compile-file-truename* :lisp2)
+(define-caller-pattern load-time-value (form (:optional form)) :lisp2)
+(define-caller-pattern disassemble (form) :lisp)
+(define-caller-pattern function-lambda-expression (fn) :lisp2)
+(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form))
+ :lisp2)
+
+;;; Documentation
+(define-caller-pattern documentation (form form) :lisp)
+(define-caller-pattern trace ((:star form)) :lisp)
+(define-caller-pattern untrace ((:star form)) :lisp)
+(define-caller-pattern step (form) :lisp)
+(define-caller-pattern time (form) :lisp)
+(define-caller-pattern describe (form &optional form) :lisp)
+(define-caller-pattern describe-object (form &optional form) :lisp2)
+(define-caller-pattern inspect (form) :lisp)
+(define-caller-pattern room ((:optional form)) :lisp)
+(define-caller-pattern ed ((:optional form)) :lisp)
+(define-caller-pattern dribble ((:optional form)) :lisp)
+(define-caller-pattern apropos (form (:optional form)) :lisp)
+(define-caller-pattern apropos-list (form (:optional form)) :lisp)
+(define-caller-pattern get-decoded-time () :lisp)
+(define-caller-pattern get-universal-time () :lisp)
+(define-caller-pattern decode-universal-time (form &optional form) :lisp)
+(define-caller-pattern encode-universal-time
+ (form form form form form form &optional form) :lisp)
+(define-caller-pattern get-internal-run-time () :lisp)
+(define-caller-pattern get-internal-real-time () :lisp)
+(define-caller-pattern sleep (form) :lisp)
+
+(define-caller-pattern lisp-implementation-type () :lisp)
+(define-caller-pattern lisp-implementation-version () :lisp)
+(define-caller-pattern machine-type () :lisp)
+(define-caller-pattern machine-version () :lisp)
+(define-caller-pattern machine-instance () :lisp)
+(define-caller-pattern software-type () :lisp)
+(define-caller-pattern software-version () :lisp)
+(define-caller-pattern short-site-name () :lisp)
+(define-caller-pattern long-site-name () :lisp)
+(define-variable-pattern *features* :lisp)
+
+(define-caller-pattern identity (form) :lisp)
+
+;;; Pretty Printing
+(define-variable-pattern *print-pprint-dispatch* :lisp2)
+(define-variable-pattern *print-right-margin* :lisp2)
+(define-variable-pattern *print-miser-width* :lisp2)
+(define-variable-pattern *print-lines* :lisp2)
+(define-caller-pattern pprint-newline (form &optional form) :lisp2)
+(define-caller-pattern pprint-logical-block
+ ((var form &key (:star form))
+ (:star form))
+ :lisp2)
+(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2)
+(define-caller-pattern pprint-pop () :lisp2)
+(define-caller-pattern pprint-indent (form form &optional form) :lisp2)
+(define-caller-pattern pprint-tab (form form form &optional form) :lisp2)
+(define-caller-pattern pprint-fill (form form &optional form form) :lisp2)
+(define-caller-pattern pprint-linear (form form &optional form form) :lisp2)
+(define-caller-pattern pprint-tabular (form form &optional form form form) :lisp2)
+(define-caller-pattern formatter (control-string) :lisp2)
+(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2)
+(define-caller-pattern pprint-dispatch (form &optional form) :lisp2)
+(define-caller-pattern set-pprint-dispatch (form form &optional form form)
+ :lisp2)
+
+;;; CLOS
+(define-caller-pattern add-method (fn form) :lisp2)
+(define-caller-pattern call-method (form form) :lisp2)
+(define-caller-pattern call-next-method ((:star form)) :lisp2)
+(define-caller-pattern change-class (form form) :lisp2)
+(define-caller-pattern class-name (form) :lisp2)
+(define-caller-pattern class-of (form) :lisp2)
+(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2)
+(define-caller-pattern defclass (name &rest :ignore) :lisp2)
+(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2)
+(define-caller-pattern define-method-combination
+ (name lambda-list ((:star :ignore))
+ (:optional ((:eq :arguments) :ignore))
+ (:optional ((:eq :generic-function) :ignore))
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp2)
+(define-caller-pattern defmethod
+ (name (:star symbol) lambda-list
+ (:star (:or declaration documentation-string))
+ (:star form))
+ :lisp2)
+(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2)
+(define-caller-pattern find-class (form &optional form form) :lisp2)
+(define-caller-pattern find-method (fn &rest :ignore) :lisp2)
+(define-caller-pattern function-keywords (&rest :ignore) :lisp2)
+(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form))
+ :lisp2)
+(define-caller-pattern generic-labels
+ (((:star (name lambda-list))) (:star form))
+ :lisp2)
+(define-caller-pattern generic-function (lambda-list) :lisp2)
+(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2)
+(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2)
+(define-caller-pattern make-instance (fn (:star form)) :lisp2)
+(define-caller-pattern make-instances-obsolete (fn) :lisp2)
+(define-caller-pattern method-combination-error (form (:star form)) :lisp2)
+(define-caller-pattern method-qualifiers (fn) :lisp2)
+(define-caller-pattern next-method-p () :lisp2)
+(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2)
+(define-caller-pattern no-next-method (fn (:star form)) :lisp2)
+(define-caller-pattern print-object (form form) :lisp2)
+(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2)
+(define-caller-pattern remove-method (fn form) :lisp2)
+(define-caller-pattern shared-initialize (form form (:star form)) :lisp2)
+(define-caller-pattern slot-boundp (form form) :lisp2)
+(define-caller-pattern slot-exists-p (form form) :lisp2)
+(define-caller-pattern slot-makeunbound (form form) :lisp2)
+(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2)
+(define-caller-pattern slot-unbound (fn form form) :lisp2)
+(define-caller-pattern slot-value (form form) :lisp2)
+(define-caller-pattern update-instance-for-different-class
+ (form form (:star form)) :lisp2)
+(define-caller-pattern update-instance-for-redefined-class
+ (form form (:star form)) :lisp2)
+(define-caller-pattern with-accessors
+ (((:star :ignore)) form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+(define-caller-pattern with-added-methods
+ ((name lambda-list) form
+ (:star form))
+ :lisp2)
+(define-caller-pattern with-slots
+ (((:star :ignore)) form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+
+;;; Conditions
+(define-caller-pattern signal (form (:star form)) :lisp2)
+(define-variable-pattern *break-on-signals* :lisp2)
+(define-caller-pattern handler-case (form (:star (form ((:optional var))
+ (:star form))))
+ :lisp2)
+(define-caller-pattern ignore-errors ((:star form)) :lisp2)
+(define-caller-pattern handler-bind (((:star (form form)))
+ (:star form))
+ :lisp2)
+(define-caller-pattern define-condition (name &rest :ignore) :lisp2)
+(define-caller-pattern make-condition (form &rest :ignore) :lisp2)
+(define-caller-pattern with-simple-restart
+ ((name form (:star form)) (:star form)) :lisp2)
+(define-caller-pattern restart-case
+ (form
+ (:star (form form (:star form))))
+ :lisp2)
+(define-caller-pattern restart-bind
+ (((:star (name fn &key (:star form))))
+ (:star form))
+ :lisp2)
+(define-caller-pattern with-condition-restarts
+ (form form
+ (:star declaration)
+ (:star form))
+ :lisp2)
+(define-caller-pattern compute-restarts (&optional form) :lisp2)
+(define-caller-pattern restart-name (form) :lisp2)
+(define-caller-pattern find-restart (form &optional form) :lisp2)
+(define-caller-pattern invoke-restart (form (:star form)) :lisp2)
+(define-caller-pattern invoke-restart-interactively (form) :lisp2)
+(define-caller-pattern abort (&optional form) :lisp2)
+(define-caller-pattern continue (&optional form) :lisp2)
+(define-caller-pattern muffle-warning (&optional form) :lisp2)
+(define-caller-pattern store-value (form &optional form) :lisp2)
+(define-caller-pattern use-value (form &optional form) :lisp2)
+(define-caller-pattern invoke-debugger (form) :lisp2)
+(define-variable-pattern *debugger-hook* :lisp2)
+(define-caller-pattern simple-condition-format-string (form) :lisp2)
+(define-caller-pattern simple-condition-format-arguments (form) :lisp2)
+(define-caller-pattern type-error-datum (form) :lisp2)
+(define-caller-pattern type-error-expected-type (form) :lisp2)
+(define-caller-pattern package-error-package (form) :lisp2)
+(define-caller-pattern stream-error-stream (form) :lisp2)
+(define-caller-pattern file-error-pathname (form) :lisp2)
+(define-caller-pattern cell-error-name (form) :lisp2)
+(define-caller-pattern arithmetic-error-operation (form) :lisp2)
+(define-caller-pattern arithmetic-error-operands (form) :lisp2)
+
+;;; For ZetaLisp Flavors
+(define-caller-pattern send (form fn (:star form)) :flavors)
1
0
18 Jan '08
Author: ksprotte
Date: Fri Jan 18 06:03:03 2008
New Revision: 2349
Removed:
branches/bos/thirdparty/emacs/slime/
Log:
rm slime to add new one with CVS
1
0
Author: ksprotte
Date: Fri Jan 18 05:27:28 2008
New Revision: 2348
Modified:
branches/bos/projects/bos/Makefile
Log:
some more targets to Makefile
Modified: branches/bos/projects/bos/Makefile
==============================================================================
--- branches/bos/projects/bos/Makefile (original)
+++ branches/bos/projects/bos/Makefile Fri Jan 18 05:27:28 2008
@@ -1,4 +1,5 @@
all: bos.core
+.PHONY: all
cmucl.core:
lisp -load make-base-lisp.lisp
@@ -6,8 +7,29 @@
bos.core: cmucl.core
./build.sh
-.PHONY: clean
-clean:
+.PHONY: cleancore
+cleancore:
rm -f cmucl.core
rm -f bos.core
+.PHONY: cleanfasl
+cleanfasl:
+ (cd ../.. && find . -name '*.x86f' | xargs rm)
+
+.PHONY: cleanall
+cleanall: cleancore cleanfasl
+
+.PHONY: clean
+clean: cleancore
+
+# I once had the problem that compiling
+# and loading a lisp source was fine,
+# but loading the pre-compiled fasl failed...
+
+.PHONY: crazy_build_test
+crazy_build_test:
+ make cleanall
+ make all
+ make cleancore
+ make all
+
1
0
Author: ksprotte
Date: Fri Jan 18 05:05:56 2008
New Revision: 2347
Added:
branches/bos/projects/bos/Makefile
Log:
Added Makefile for building / cleaning *.core
Added: branches/bos/projects/bos/Makefile
==============================================================================
--- (empty file)
+++ branches/bos/projects/bos/Makefile Fri Jan 18 05:05:56 2008
@@ -0,0 +1,13 @@
+all: bos.core
+
+cmucl.core:
+ lisp -load make-base-lisp.lisp
+
+bos.core: cmucl.core
+ ./build.sh
+
+.PHONY: clean
+clean:
+ rm -f cmucl.core
+ rm -f bos.core
+
1
0
Author: ksprotte
Date: Fri Jan 18 04:34:29 2008
New Revision: 2346
Modified:
branches/bos/projects/bos/m2/allocation-cache.lisp
Log:
small ch
Modified: branches/bos/projects/bos/m2/allocation-cache.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-cache.lisp (original)
+++ branches/bos/projects/bos/m2/allocation-cache.lisp Fri Jan 18 04:34:29 2008
@@ -136,7 +136,7 @@
(<= 1 n +threshold+))
(defun find-exact-match (n &key remove)
- "Will return a free contigous region of size N
+ "Will return a free contiguous region of size N
as a list of m2 instances. If no such region exactly
matching N can be found, simply returns NIL.
1
0
Author: hhubner
Date: Fri Jan 18 03:32:49 2008
New Revision: 2345
Modified:
branches/bos/projects/bos/web/packages.lisp
Log:
Add package alias so that old store can be loaded.
Modified: branches/bos/projects/bos/web/packages.lisp
==============================================================================
--- branches/bos/projects/bos/web/packages.lisp (original)
+++ branches/bos/projects/bos/web/packages.lisp Fri Jan 18 03:32:49 2008
@@ -25,6 +25,7 @@
:bknr.rss
:bos.m2
:bos.m2.config)
+ (:nicknames :web :worldpay-test)
(:shadowing-import-from :cl-interpol #:quote-meta-chars)
(:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait)
(:import-from :net.html.generator #:*html-stream*)
1
0
Author: hhubner
Date: Fri Jan 18 03:00:36 2008
New Revision: 2344
Added:
branches/bos/projects/bos/web/startup.lisp
- copied unchanged from r2343, branches/bos/projects/bos/web/web.lisp
Removed:
branches/bos/projects/bos/web/web.lisp
Modified:
branches/bos/projects/bos/web/bos.web.asd
Log:
Final tweaks to get rid of the worldpay-test package and system.
Modified: branches/bos/projects/bos/web/bos.web.asd
==============================================================================
--- branches/bos/projects/bos/web/bos.web.asd (original)
+++ branches/bos/projects/bos/web/bos.web.asd Fri Jan 18 03:00:36 2008
@@ -2,12 +2,12 @@
(in-package :cl-user)
-(defpackage :worldpay-test.system
+(defpackage :bos.web.system
(:use :cl :asdf))
-(in-package :worldpay-test.system)
+(in-package :bos.web.system)
-(defsystem :worldpay-test
+(defsystem :bos.web
:name "worldpay test"
:author "Hans Huebner <hans(a)huebner.org>"
:version "0"
1
0
[bknr-cvs] r2343 - in branches/bos/projects/bos: web worldpay-test
by hhubner＠common-lisp.net 18 Jan '08
by hhubner＠common-lisp.net 18 Jan '08
18 Jan '08
Author: hhubner
Date: Fri Jan 18 02:56:09 2008
New Revision: 2343
Added:
branches/bos/projects/bos/web/
- copied from r2337, branches/bos/projects/bos/worldpay-test/
branches/bos/projects/bos/web/allocation-area-handlers.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp
branches/bos/projects/bos/web/boi-handlers.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/boi-handlers.lisp
branches/bos/projects/bos/web/bos.web.asd
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/bos.web.asd
branches/bos/projects/bos/web/cms-links.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/cms-links.lisp
branches/bos/projects/bos/web/config.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/config.lisp
branches/bos/projects/bos/web/contract-handlers.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/contract-handlers.lisp
branches/bos/projects/bos/web/contract-image-handler.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/contract-image-handler.lisp
branches/bos/projects/bos/web/contract-rss.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/contract-rss.lisp
branches/bos/projects/bos/web/daily.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/daily.lisp
branches/bos/projects/bos/web/languages-handler.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/languages-handler.lisp
branches/bos/projects/bos/web/map-browser-handler.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/map-browser-handler.lisp
branches/bos/projects/bos/web/map-handlers.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/map-handlers.lisp
branches/bos/projects/bos/web/news-handlers.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/news-handlers.lisp
branches/bos/projects/bos/web/news-rss.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/news-rss.lisp
branches/bos/projects/bos/web/news-tags.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/news-tags.lisp
branches/bos/projects/bos/web/packages.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/packages.lisp
branches/bos/projects/bos/web/poi-handlers.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/poi-handlers.lisp
branches/bos/projects/bos/web/reports-xml-handler.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/reports-xml-handler.lisp
branches/bos/projects/bos/web/rss.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/rss.lisp
branches/bos/projects/bos/web/spendenquittung.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/spendenquittung.lisp
branches/bos/projects/bos/web/sponsor-handlers.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp
branches/bos/projects/bos/web/tags.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/tags.lisp
branches/bos/projects/bos/web/utils.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/utils.lisp
branches/bos/projects/bos/web/web-macros.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/web-macros.lisp
branches/bos/projects/bos/web/web-utils.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/web-utils.lisp
branches/bos/projects/bos/web/web.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/web.lisp
branches/bos/projects/bos/web/webserver.lisp
- copied unchanged from r2342, branches/bos/projects/bos/worldpay-test/webserver.lisp
Removed:
branches/bos/projects/bos/web/worldpay-test.asd
branches/bos/projects/bos/web/worldpay-test.lisp
branches/bos/projects/bos/worldpay-test/
Log:
rename worldpay-test -> bos.web, step 2
1
0
[bknr-cvs] r2342 - in branches/bos/projects/bos: m2 web worldpay-test
by hhubner＠common-lisp.net 18 Jan '08
by hhubner＠common-lisp.net 18 Jan '08
18 Jan '08
Author: hhubner
Date: Fri Jan 18 02:53:56 2008
New Revision: 2342
Added:
branches/bos/projects/bos/worldpay-test/bos.web.asd
- copied, changed from r2337, branches/bos/projects/bos/worldpay-test/worldpay-test.asd
branches/bos/projects/bos/worldpay-test/web.lisp
- copied, changed from r2337, branches/bos/projects/bos/web/web.lisp
branches/bos/projects/bos/worldpay-test/webserver.lisp
- copied, changed from r2337, branches/bos/projects/bos/worldpay-test/worldpay-test.lisp
Removed:
branches/bos/projects/bos/web/
branches/bos/projects/bos/worldpay-test/worldpay-test.asd
branches/bos/projects/bos/worldpay-test/worldpay-test.lisp
Modified:
branches/bos/projects/bos/m2/mail-generator.lisp
branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp
branches/bos/projects/bos/worldpay-test/boi-handlers.lisp
branches/bos/projects/bos/worldpay-test/cms-links.lisp
branches/bos/projects/bos/worldpay-test/config.lisp
branches/bos/projects/bos/worldpay-test/contract-handlers.lisp
branches/bos/projects/bos/worldpay-test/contract-image-handler.lisp
branches/bos/projects/bos/worldpay-test/contract-rss.lisp
branches/bos/projects/bos/worldpay-test/daily.lisp
branches/bos/projects/bos/worldpay-test/languages-handler.lisp
branches/bos/projects/bos/worldpay-test/map-browser-handler.lisp
branches/bos/projects/bos/worldpay-test/map-handlers.lisp
branches/bos/projects/bos/worldpay-test/news-handlers.lisp
branches/bos/projects/bos/worldpay-test/news-rss.lisp
branches/bos/projects/bos/worldpay-test/news-tags.lisp
branches/bos/projects/bos/worldpay-test/packages.lisp
branches/bos/projects/bos/worldpay-test/poi-handlers.lisp
branches/bos/projects/bos/worldpay-test/reports-xml-handler.lisp
branches/bos/projects/bos/worldpay-test/rss.lisp
branches/bos/projects/bos/worldpay-test/spendenquittung.lisp
branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp
branches/bos/projects/bos/worldpay-test/tags.lisp
branches/bos/projects/bos/worldpay-test/utils.lisp
branches/bos/projects/bos/worldpay-test/web-macros.lisp
branches/bos/projects/bos/worldpay-test/web-utils.lisp
Log:
rename worldpay-test -> bos.web, step 1
Modified: branches/bos/projects/bos/m2/mail-generator.lisp
==============================================================================
--- branches/bos/projects/bos/m2/mail-generator.lisp (original)
+++ branches/bos/projects/bos/m2/mail-generator.lisp Fri Jan 18 02:53:56 2008
@@ -45,7 +45,7 @@
(defun mail-template-directory (language)
"Return the directory where the mail templates are stored"
(merge-pathnames (make-pathname :directory `(:relative "templates" ,(string-downcase language)))
- (symbol-value (find-symbol "*WEBSITE-DIRECTORY*" "WORLDPAY-TEST"))))
+ (symbol-value (find-symbol "*WEBSITE-DIRECTORY*" "BOS.WEB"))))
(defun rest-of-file (file)
(let ((result (make-array (- (file-length file)
Modified: branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/allocation-area-handlers.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/boi-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/boi-handlers.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/boi-handlers.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Copied: branches/bos/projects/bos/worldpay-test/bos.web.asd (from r2337, branches/bos/projects/bos/worldpay-test/worldpay-test.asd)
==============================================================================
--- branches/bos/projects/bos/worldpay-test/worldpay-test.asd (original)
+++ branches/bos/projects/bos/worldpay-test/bos.web.asd Fri Jan 18 02:53:56 2008
@@ -38,7 +38,15 @@
(:file "news-tags" :depends-on ("web-utils"))
(:file "news-rss" :depends-on ("web-utils"))
(:file "contract-rss" :depends-on ("web-utils"))
- (:file "worldpay-test" :depends-on ("news-tags" "tags" "map-handlers" "map-browser-handler" "poi-handlers"
- "boi-handlers" "contract-handlers" "sponsor-handlers" "news-handlers"
- "allocation-area-handlers"))
- (:file "daily" :depends-on ("config" "worldpay-test"))))
+ (:file "webserver" :depends-on ("news-tags"
+ "tags"
+ "map-handlers"
+ "map-browser-handler"
+ "poi-handlers"
+ "boi-handlers"
+ "contract-handlers"
+ "sponsor-handlers"
+ "news-handlers"
+ "allocation-area-handlers"))
+ (:file "daily" :depends-on ("config" "webserver"))
+ (:file "startup" :depends-on ("config" "webserver"))))
Modified: branches/bos/projects/bos/worldpay-test/cms-links.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/cms-links.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/cms-links.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/config.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/config.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/config.lisp Fri Jan 18 02:53:56 2008
@@ -1,4 +1,4 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
;; Worldpay (headcraft inst id ist 102532
(defparameter *worldpay-installation-id* 103530
Modified: branches/bos/projects/bos/worldpay-test/contract-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/contract-handlers.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/contract-handlers.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/contract-image-handler.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/contract-image-handler.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/contract-image-handler.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/contract-rss.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/contract-rss.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/contract-rss.lisp Fri Jan 18 02:53:56 2008
@@ -7,7 +7,7 @@
(contract-paidp contract))
(defmethod rss-item-title ((contract contract))
- (format nil (case (intern (worldpay-test::current-website-language))
+ (format nil (case (intern (bos.web::current-website-language))
(de "~A Quadratmeter wurden ~@[von ~A ~]gekauft")
(t "~A square meters bought~@[ by ~A~]"))
(length (contract-m2s contract))
@@ -18,11 +18,11 @@
(defmethod rss-item-link ((contract contract))
#+(or)
- (format nil "http://createrainforest.org/~A/news-extern/~A" (worldpay-test::current-website-language) (store-object-id item)))
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (bos.web::current-website-language) (store-object-id item)))
(defmethod rss-item-guid ((item contract))
#+(or)
- (format nil "http://createrainforest.org/~A/news-extern/~A" (worldpay-test::current-website-language) (store-object-id item)))
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (bos.web::current-website-language) (store-object-id item)))
(defmethod rss-item-pub-date ((contract contract))
(contract-date contract))
Modified: branches/bos/projects/bos/worldpay-test/daily.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/daily.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/daily.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(defun daily-cleanup ()
(format t "; performing daily cleanup run~%")
Modified: branches/bos/projects/bos/worldpay-test/languages-handler.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/languages-handler.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/languages-handler.lisp Fri Jan 18 02:53:56 2008
@@ -1,4 +1,4 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/map-browser-handler.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/map-browser-handler.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/map-browser-handler.lisp Fri Jan 18 02:53:56 2008
@@ -1,7 +1,7 @@
; please don't read this code, it is not pretty
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/map-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/map-handlers.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/map-handlers.lisp Fri Jan 18 02:53:56 2008
@@ -1,4 +1,4 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/news-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/news-handlers.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/news-handlers.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/news-rss.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/news-rss.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/news-rss.lisp Fri Jan 18 02:53:56 2008
@@ -4,19 +4,19 @@
"news")
(defmethod rss-item-published ((item news-item))
- (news-item-published item (worldpay-test::current-website-language)))
+ (news-item-published item (bos.web::current-website-language)))
(defmethod rss-item-title ((item news-item))
- (news-item-title item (worldpay-test::current-website-language)))
+ (news-item-title item (bos.web::current-website-language)))
(defmethod rss-item-description ((item news-item))
- (news-item-text item (worldpay-test::current-website-language)))
+ (news-item-text item (bos.web::current-website-language)))
(defmethod rss-item-link ((item news-item))
- (format nil "http://createrainforest.org/~A/news-extern/~A" (worldpay-test::current-website-language) (store-object-id item)))
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (bos.web::current-website-language) (store-object-id item)))
(defmethod rss-item-guid ((item news-item))
- (format nil "http://createrainforest.org/~A/news-extern/~A" (worldpay-test::current-website-language) (store-object-id item)))
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (bos.web::current-website-language) (store-object-id item)))
(defmethod rss-item-pub-date ((item news-item))
(news-item-time item))
Modified: branches/bos/projects/bos/worldpay-test/news-tags.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/news-tags.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/news-tags.lisp Fri Jan 18 02:53:56 2008
@@ -1,4 +1,4 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/packages.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/packages.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/packages.lisp Fri Jan 18 02:53:56 2008
@@ -1,6 +1,6 @@
(in-package :cl-user)
-(defpackage :worldpay-test
+(defpackage :bos.web
(:use :cl
:date-calc
#+cmu :extensions
Modified: branches/bos/projects/bos/worldpay-test/poi-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/poi-handlers.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/poi-handlers.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/reports-xml-handler.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/reports-xml-handler.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/reports-xml-handler.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
@@ -29,7 +29,7 @@
(not (eql *year* (contract-year contract))))))
(class-instances 'contract))
#'< :key #'contract-date)))
- (setf name (intern (string-upcase name) :worldpay-test))
+ (setf name (intern (string-upcase name) :bos.web))
(apply (or (gethash name *report-generators*)
(error "invalid report name ~A" name))
arguments)))))
Modified: branches/bos/projects/bos/worldpay-test/rss.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/rss.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/rss.lisp Fri Jan 18 02:53:56 2008
@@ -1,6 +1,6 @@
;; 2008-01-15: currently not used in the production core
-(in-package :worldpay-test)
+(in-package :bos.web)
(defmethod rss-item-channel ((item news-item))
"news")
Modified: branches/bos/projects/bos/worldpay-test/spendenquittung.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/spendenquittung.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/spendenquittung.lisp Fri Jan 18 02:53:56 2008
@@ -91,7 +91,7 @@
(with-output-to-string (s)
(pdf:write-document s))))
-(in-package :worldpay-test)
+(in-package :bos.web)
(defvar *mail-sender-name* "BOS Deutschland e.V.")
(defvar *mail-sender-address* "spendenbescheinigung(a)bos-deutschland.de")
Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/tags.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/tags.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/tags.lisp Fri Jan 18 02:53:56 2008
@@ -1,4 +1,4 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/utils.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/utils.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/utils.lisp Fri Jan 18 02:53:56 2008
@@ -1,6 +1,6 @@
;; 2008-01-15: currently not used in the production core
-(in-package :worldpay-test)
+(in-package :bos.web)
;;; date format
Modified: branches/bos/projects/bos/worldpay-test/web-macros.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/web-macros.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/web-macros.lisp Fri Jan 18 02:53:56 2008
@@ -1,4 +1,4 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Modified: branches/bos/projects/bos/worldpay-test/web-utils.lisp
==============================================================================
--- branches/bos/projects/bos/worldpay-test/web-utils.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/web-utils.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
Copied: branches/bos/projects/bos/worldpay-test/web.lisp (from r2337, branches/bos/projects/bos/web/web.lisp)
==============================================================================
--- branches/bos/projects/bos/web/web.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/web.lisp Fri Jan 18 02:53:56 2008
@@ -30,10 +30,10 @@
(defun reinit (&key debug)
(format t "~&; Publishing BOS handlers.~%")
(unpublish :all t)
- (worldpay-test::publish-worldpay-test :website-directory *website-directory*
- :vhosts *vhosts*
- :website-url *website-url*
- :worldpay-test-mode *worldpay-test-mode*)
+ (bos.web::publish-website :website-directory *website-directory*
+ :vhosts *vhosts*
+ :website-url *website-url*
+ :worldpay-test-mode *worldpay-test-mode*)
(format t "~&; Starting aserve~@[ in debug mode~].~%" debug)
(force-output)
(setq *webserver*
Copied: branches/bos/projects/bos/worldpay-test/webserver.lisp (from r2337, branches/bos/projects/bos/worldpay-test/worldpay-test.lisp)
==============================================================================
--- branches/bos/projects/bos/worldpay-test/worldpay-test.lisp (original)
+++ branches/bos/projects/bos/worldpay-test/webserver.lisp Fri Jan 18 02:53:56 2008
@@ -1,5 +1,5 @@
-(in-package :worldpay-test)
+(in-package :bos.web)
(enable-interpol-syntax)
@@ -174,7 +174,7 @@
(find-browser-prefered-language req)
*default-language*)))))
-(defun publish-worldpay-test (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))
+(defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))
(setf *website-directory* website-directory)
(when website-url
@@ -219,7 +219,7 @@
("/index" index-handler)
("/" worldpay-template-handler
:destination ,(namestring (merge-pathnames #p"templates/" website-directory))
- :command-packages ((:bos . :worldpay-test)
+ :command-packages ((:bos . :bos.web)
(:bknr . :bknr.web))))
:modules '(user images stats)
:navigation '(("sponsor" . "edit-sponsor/")
1
0
Author: hhubner
Date: Fri Jan 18 02:45:07 2008
New Revision: 2341
Modified:
branches/bos/projects/bos/README
Log:
small corrections to better reflect reality
Modified: branches/bos/projects/bos/README
==============================================================================
--- branches/bos/projects/bos/README (original)
+++ branches/bos/projects/bos/README Fri Jan 18 02:45:07 2008
@@ -6,14 +6,14 @@
- CMUCL 19c installieren, so dass "lisp" im Pfad ist
- - Komplettes cvs auschecken:
- $ cvs -d :ext:bknr.net:/home/bknr/cvs co -d bknr.net .
+ - Komplettes svn auschecken:
+ $ svn co svn+ssh://common-lisp.net/project/bknr/svn/branches/bos/projects/bos bknr-svn
Image bauen
-----------
- Im BOS-Verzeichnis eingeben
- bknr.net/bos$ ./build.sh --clean
+ bknr.net/bos$ ./build.sh
(--clean loescht fasls vor dem Kompilieren.)
- Heraus kommt das Imagefile "bos.core", das auf den Kundenserver
1
0
Author: hhubner
Date: Thu Jan 17 12:09:12 2008
New Revision: 2340
Modified:
branches/bos/projects/bos/m2/map.lisp
Log:
If no background image is available, just skip the :background operation.
Modified: branches/bos/projects/bos/m2/map.lisp
==============================================================================
--- branches/bos/projects/bos/m2/map.lisp (original)
+++ branches/bos/projects/bos/m2/map.lisp Thu Jan 17 12:09:12 2008
@@ -118,8 +118,9 @@
original-image))
(defmethod image-tile-process ((tile image-tile) (operation (eql :background)))
- (with-store-image (original-image (image-tile-original-image tile))
- (copy-image original-image *default-image* 0 0 0 0 (image-width) (image-height))))
+ (when (image-tile-original-image tile)
+ (with-store-image (original-image (image-tile-original-image tile))
+ (copy-image original-image *default-image* 0 0 0 0 (image-width) (image-height)))))
(defmethod image-tile-process ((tile image-tile) (operation (eql :areas)))
(do-rows (y)
1
0
Author: ksprotte
Date: Thu Jan 17 11:52:36 2008
New Revision: 2339
Added:
branches/bos-ksprotte/
- copied from r2338, branches/bos/
Log:
created new test branch for ksprotte
1
0
Author: ksprotte
Date: Thu Jan 17 11:51:11 2008
New Revision: 2338
Removed:
branches/bos-sehr-alt/
Log:
rm branch bos-sehr-alt
1
0
Author: ksprotte
Date: Thu Jan 17 11:39:36 2008
New Revision: 2337
Modified:
branches/bos/projects/bos/m2/packages.lisp
Log:
again prefix rename
Modified: branches/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp (original)
+++ branches/bos/projects/bos/m2/packages.lisp Thu Jan 17 11:39:36 2008
@@ -229,9 +229,9 @@
:bos.m2.config
:iterate)
(:import-from :bos.m2 bos.m2::point-in-polygon-p)
- (:export #:allocation-cache-find-exact-match
- #:allocation-cache-add-area
- #:allocation-cache-free-regions-count
- #:allocation-cache-free-regions-pprint
+ (:export #:find-exact-match
+ #:add-area
+ #:free-regions-count
+ #:free-regions-pprint
#:rebuild-cache))
1
0
[bknr-cvs] r2336 - in branches/trunk-reorg: bknr/web/src bknr/web/src/web projects/lisp-ecoop/src projects/scrabble/src projects/scrabble/website thirdparty/hunchentoot-0.14.7 thirdparty/parenscript/src thirdparty/slime
by hhubner＠common-lisp.net 17 Jan '08
by hhubner＠common-lisp.net 17 Jan '08
17 Jan '08
Author: hhubner
Date: Thu Jan 17 11:36:28 2008
New Revision: 2336
Added:
branches/trunk-reorg/projects/scrabble/website/scrabble-resizable-attempt.js
Modified:
branches/trunk-reorg/bknr/web/src/bknr-web.asd
branches/trunk-reorg/bknr/web/src/web/handlers.lisp
branches/trunk-reorg/bknr/web/src/web/menu.lisp
branches/trunk-reorg/bknr/web/src/web/templates.lisp
branches/trunk-reorg/bknr/web/src/web/web-utils.lisp
branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd
branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp
branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp
branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp
branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp
branches/trunk-reorg/projects/scrabble/src/web.lisp
branches/trunk-reorg/projects/scrabble/website/scrabble.html
branches/trunk-reorg/projects/scrabble/website/scrabble.js
branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp
branches/trunk-reorg/thirdparty/parenscript/src/js-macrology.lisp
branches/trunk-reorg/thirdparty/slime/slime.el
branches/trunk-reorg/thirdparty/slime/swank.lisp
Log:
Save pending lisp-ecoop and scrabble changes.
Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd
==============================================================================
--- branches/trunk-reorg/bknr/web/src/bknr-web.asd (original)
+++ branches/trunk-reorg/bknr/web/src/bknr-web.asd Thu Jan 17 11:36:28 2008
@@ -32,7 +32,8 @@
:xhtmlgen
:puri
:bknr-datastore
- :bknr-data-impex)
+ :bknr-data-impex
+ :parenscript)
:components ((:file "packages")
@@ -59,7 +60,6 @@
:depends-on ("parse-xml" "rss")))
:depends-on ("packages"))
- #+notyet
(:module "web" :components ((:file "site")
;; data
(:file "host")
Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Thu Jan 17 11:36:28 2008
@@ -229,7 +229,7 @@
(setf (session-variable :login-redirect-uri)
(redirect-uri (request-uri req)))
(redirect (website-make-path *website* "login") req))
- (if (member :notrap net.aserve::*debug-current* :test #'eq)
+ (if hunchentoot:*catch-errors-p*
(handle handler req)
(handler-bind ((error #'(lambda (e)
(with-bknr-http-response (*req* :content-type "text/html; charset=UTF-8"
@@ -533,7 +533,7 @@
(defun show-page-with-error-handlers (fn req &key response title)
(unless response
(setf response *response-ok*)) ; can't default because used from macros and *response-ok* is not a constant
- (if (member :notrap net.aserve::*debug-current*)
+ (if hunchentoot:*catch-errors-p*
(with-bknr-http-response (req :content-type "text/html; charset=UTF-8" :response response)
(with-http-body (req *ent*)
(website-show-page *website* fn title)))
Modified: branches/trunk-reorg/bknr/web/src/web/menu.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/menu.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/menu.lisp Thu Jan 17 11:36:28 2008
@@ -50,7 +50,7 @@
(when title
(html ((:div :class "title") (:princ-safe title))))
(dolist (item (menu-items menu))
- (let ((item-is-active (in-subtree (puri:uri-path (net.aserve:request-uri *req*)) (item-url item))))
+ (let ((item-is-active (in-subtree (request-uri) (item-url item))))
(with-slots (url title active-image inactive-image) item
(let ((link-url (format nil "~A~A" (website-base-href *website*) url)))
(cond
Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Thu Jan 17 11:36:28 2008
@@ -12,11 +12,11 @@
"/usr/local/share/xml/catalog.ports"))
(eval-when (:load-toplevel :execute)
- (let ((env-catalog (assoc :xmlcatalog ext:*environment-list*)))
+ (let ((env-catalog (sb-ext:posix-getenv "XMLCATALOG")))
(when env-catalog
- (pushnew (cdr env-catalog) *template-dtd-catalog* :test #'equal))))
+ (pushnew env-catalog *template-dtd-catalog* :test #'equal))))
-;; user-error is supposed to be raised when an error is provoced by
+;; user-error is supposed to be raised when an error is provoked by
;; the user (i.e. by supplying invalid form data).
(define-condition user-error (simple-error)
@@ -272,7 +272,7 @@
handler req)))))))
(defun invoke-with-error-handlers (fn handler req)
- (if (member :notrap net.aserve::*debug-current*)
+ (if hunchentoot:*catch-errors-p*
(handler-case
(funcall fn)
(template-not-found (c)
Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp (original)
+++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Thu Jan 17 11:36:28 2008
@@ -293,4 +293,4 @@
(princ " />"))))
(defun encode-urlencoded (string)
- (regex-replace-all #?r"\+" (net.aserve::encode-form-urlencoded string) "%20"))
\ No newline at end of file
+ (url-encode string))
\ No newline at end of file
Modified: branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd (original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd Thu Jan 17 11:36:28 2008
@@ -16,15 +16,22 @@
:description "Website for the LISP ECOOP Workshops"
:long-description ""
- :depends-on (:bknr-modules :cxml :klammerscript)
+ :depends-on (:bknr-datastore
+ :bknr-web
+ :cxml)
:components ((:file "packages")
(:file "config" :depends-on ("packages"))
(:file "macros" :depends-on ("config"))
+ #+(or)
(:file "schedule" :depends-on ("macros"))
+ #+(or)
(:file "participant" :depends-on ("macros" "schedule"))
+ #+(or)
(:file "mail" :depends-on ("participant"))
+ #+(or)
(:file "tags" :depends-on ("participant"))
+ #+(or)
(:file "handlers" :depends-on ("participant"))
- (:file "webserver" :depends-on ("handlers"))
+ (:file "webserver" :depends-on (#+(or) "handlers"))
(:file "init" :depends-on ("webserver"))))
Modified: branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp (original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp Thu Jan 17 11:36:28 2008
@@ -1,6 +1,6 @@
(in-package :lisp-ecoop)
-(defvar *dtd* (ext:unix-namestring (merge-pathnames #p"src/lisp-ecoop.dtd" lisp-ecoop.config::*root-directory*)))
+(defvar *dtd* (namestring (merge-pathnames #p"src/lisp-ecoop.dtd" lisp-ecoop.config::*root-directory*)))
(defun compute-slot (class slot)
(destructuring-bind (name access &rest rest &key attribute element &allow-other-keys) slot
Modified: branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp (original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp Thu Jan 17 11:36:28 2008
@@ -23,7 +23,6 @@
(defpackage :lisp-ecoop
(:use :cl
:cl-user
- :ext
:cl-interpol
:cl-ppcre
:bknr.utils
@@ -34,8 +33,7 @@
:bknr.images
:bknr.impex
:lisp-ecoop.config
- :net.aserve
- :net.post-office
+ :hunchentoot
:xhtml-generator)
(:shadowing-import-from :cl-interpol #:quote-meta-chars)
(:export #:participant
@@ -70,16 +68,14 @@
:cl-user
:cl-ppcre
:cl-interpol
- :ext
:bknr.web
:bknr.utils
:bknr.datastore
:bknr.user
:bknr.images
- :net.aserve
+ :hunchentoot
:xhtml-generator
:lisp-ecoop.config
:lisp-ecoop)
(:shadowing-import-from :cl-interpol #:quote-meta-chars)
- (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait)
(:export #:hello))
\ No newline at end of file
Modified: branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp (original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp Thu Jan 17 11:36:28 2008
@@ -34,6 +34,8 @@
())
(defun parse-time-spec (string)
+ (error "cannot parse time ~A yet" string)
+ #+(or)
(or (ignore-errors (parse-integer string))
(ext:parse-time string :default-zone -2))) ; XXX deal with time zone correctly!
Modified: branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp (original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp Thu Jan 17 11:36:28 2008
@@ -5,9 +5,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+#+(or)
(defun make-daily-statistics ()
(bknr.stats::make-yesterdays-stats :delete-events t :remove-referer-hosts '("lisp-ecoop.bknr.net")))
+#+(or)
(defun publish-lisp-ecoop (&key (port *webserver-port*) (listeners 20) (base-href *base-path*))
(unless (bknr.cron:cron-job-with-name "daily webserver statistics")
@@ -34,3 +36,11 @@
:javascript-urls (list (format nil "~Astatic/javascript.js" base-href)))
(start :port port :listeners listeners))
+
+(defun start-webserver (&key (port 9000))
+ (when (and (boundp '*server*) *server*)
+ (stop-server *server*))
+ (setq *dispatch-table*
+ (list 'dispatch-easy-handlers
+ (create-folder-dispatcher-and-handler "/" *website-directory*)))
+ (setq *server* (start-server :port port)))
\ No newline at end of file
Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp
==============================================================================
--- branches/trunk-reorg/projects/scrabble/src/web.lisp (original)
+++ branches/trunk-reorg/projects/scrabble/src/web.lisp Thu Jan 17 11:36:28 2008
@@ -46,6 +46,7 @@
(defmethod encode-json ((tile blank-tile) stream)
(encode-json-plist (append (list :letter nil
+ :letter-name nil
:value 0)
(awhen (used-for tile)
(list :used-for it)))
Added: branches/trunk-reorg/projects/scrabble/website/scrabble-resizable-attempt.js
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble-resizable-attempt.js Thu Jan 17 11:36:28 2008
@@ -0,0 +1,615 @@
+// -*- JavaScript -*-
+
+var boardScoring = [["triple-word",null,null,"double-letter",null,null,null,"triple-word",
+ null,null,null,"double-letter",null,null,"triple-word"],
+ [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"double-word",null],
+ [null,null,"double-word",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-word",null,null],
+ ["double-letter",null,null,"double-word",null,null,null,"double-letter",
+ null,null,null,"double-word",null,null,"double-letter"],
+ [null,null,null,null,"double-word",null,null,null,null,null,"double-word",
+ null,null,null,null],
+ [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"triple-letter",null],
+ [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-letter",null,null],
+ ["triple-word",null,null,"double-letter",null,null,null,"double-word",
+ null,null,null,"double-letter",null,null,"triple-word"],
+ [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-letter",null,null],
+ [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"triple-letter",null],
+ [null,null,null,null,"double-word",null,null,null,null,null,"double-word",
+ null,null,null,null],
+ ["double-letter",null,null,"double-word",null,null,null,"double-letter",
+ null,null,null,"double-word",null,null,"double-letter"],
+ [null,null,"double-word",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-word",null,null],
+ [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"double-word",null],
+ ["triple-word",null,null,"double-letter",null,null,null,"triple-word",
+ null,null,null,"double-letter",null,null,"triple-word"]];
+
+// Scrabble rule enforcement
+
+function checkMoveLegality(placedTiles)
+{
+ // Given the board and list of placed tiles, either throw an error or
+ // return if the move is legal.
+
+ var positions = map(function (placement) { return [ placement.x, placement.y ] }, placedTiles)
+ .sort(function (a, b) { return (a[0] - b[0]) || (a[1] - b[1])});
+
+ if (filter(partial(operator.ne, positions[0][0]), map(function (position) { return position[0] }, positions)).length
+ && filter(partial(operator.ne, positions[0][1]), map(function (position) { return position[1] }, positions)).length) {
+ throw "not-in-a-row";
+ }
+
+ var startOfPlacement = positions[0];
+ var endOfPlacement = positions[positions.length - 1];
+
+ for (var x = startOfPlacement[0]; x <= endOfPlacement[0]; x++) {
+ for (var y = startOfPlacement[1]; y <= endOfPlacement[1]; y++) {
+ if (!letterAt(x, y) && (findValue(positions, [ x, y ]) == -1)) {
+ throw "placement-with-holes";
+ }
+ }
+ }
+
+ if (findValue(positions, [ 7, 7 ]) == -1) {
+ var found = false;
+ for (var x = startOfPlacement[0]; !found && (x <= endOfPlacement[0]); x++) {
+ for (var y = startOfPlacement[1]; !found && (y <= endOfPlacement[1]); y++) {
+ if (((x > 0) && letterAt(x - 1, y))
+ || ((x < 14) && letterAt(x + 1, y))
+ || ((y > 0) && letterAt(x, y - 1))
+ || ((y < 14) && letterAt(x, y + 1))) {
+ found = true;
+ }
+ }
+ }
+ if (!found) {
+ throw "not-touching-other-tile";
+ }
+ }
+}
+
+// Size calculations
+
+var fieldBorderSize = 4;
+var fieldSize = 40;
+var tileBorderSize = 3;
+var tileSize = 34;
+var cellSize = 44;
+
+function calculateFieldSize()
+{
+ // Our maximum field size is 44x44 pixels. If the window is not
+ // high enough to accomodate the board, scale down.
+
+ var requiredHeight = 16 * 44 + 40; // 16 fields (including player tray) + borders
+ var viewportHeight = YAHOO.util.Dom.getViewportHeight();
+ fieldSize = Math.floor((Math.min(requiredHeight, viewportHeight) - 40) / 16);
+ fieldBorderSize = Math.floor(fieldSize / 10);
+ fieldSize -= fieldBorderSize;
+ tileSize = Math.floor(fieldSize * 34 / 40);
+ tileBorderSize = Math.round((fieldSize - tileSize) / 2);
+ cellSize = fieldBorderSize + fieldSize;
+// alert('fieldSize: ' + fieldSize + ' fieldBorderSize: ' + fieldBorderSize
+// + ' tileSize: ' + tileSize + ' tileBorderSize: ' + tileBorderSize);
+}
+
+
+//
+
+function getFieldScore(x, y) {
+ return boardScoring[x][y] || 'standard';
+}
+
+var theirTrays;
+var tray = [];
+
+var gameID = 108;
+var board;
+
+var border = 10;
+
+function makeBoard() {
+ calculateFieldSize();
+ var container = $('playfield');
+ board = [];
+ for (x = 0; x < 15; x++) {
+ board[x] = [];
+ for (y = 0; y < 15; y++) {
+ var element = IMG();
+ element.style.position = 'absolute';
+ element.style.width = fieldSize + 'px';
+ element.style.height = fieldSize + 'px';
+ element.xPos = x;
+ element.yPos = y;
+ var imageName = (x == 7 && y == 7) ? "start-field" : getFieldScore(x, y);
+ element.src = 'images/' + imageName + '.png';
+ setElementPosition(element, { x: border + x * cellSize, y: border + y * cellSize });
+ YAHOO.util.Event.on(element, 'click', emptyTileClicked);
+ board[x][y] = element;
+ }
+ appendChildNodes(container, board[x]);
+ }
+
+ var shuffleButton = DIV(null, "shuffle");
+ shuffleButton.style.color = 'white';
+ shuffleButton.style.position = 'absolute';
+ shuffleButton.onclick = shuffleMyTray;
+ setElementPosition(shuffleButton, { x: border + 480, y: border + 665 });
+ appendChildNodes(container, shuffleButton);
+
+ var gameLog = DIV({ id: 'gameLog' }, "");
+ gameLog.style.position = 'absolute';
+ gameLog.style.width = '280px';
+ gameLog.style.height = '250px';
+ gameLog.style.textAlign = 'left';
+ gameLog.style.overflowY = 'scroll';
+ setElementPosition(gameLog, { x: border + 680, y: border + 400 });
+ appendChildNodes($('playfield'), gameLog);
+
+ var nextTurn = DIV({ id: 'nextTurn' }, "");
+ nextTurn.style.position = 'absolute';
+ nextTurn.style.width = '280px';
+ nextTurn.style.textAlign = 'left';
+ setElementPosition(nextTurn, { x: border + 680, y: border + 665 });
+ appendChildNodes($('playfield'), nextTurn);
+
+ var nextTurn = DIV({ id: 'status' }, "");
+ nextTurn.style.position = 'absolute';
+ nextTurn.style.width = '280px';
+ nextTurn.style.textAlign = 'left';
+ setElementPosition(nextTurn, { x: border + 680, y: border + 680 });
+ appendChildNodes($('playfield'), nextTurn);
+}
+
+function setLetter(x, y, letter, isBlank) {
+ var image = IMG({ src: 'images/' + letter + (isBlank ? "-blank" : "") + '.png'});
+ image.style.position = 'absolute';
+ image.style.top = '3px';
+ image.style.left = '3px';
+ image.style.width = tileSize + 'px';
+ image.style.height = tileSize + 'px';
+ setElementPosition(image, { x: border + x * cellSize + tileBorderSize,
+ y: border + y * cellSize + tileBorderSize });
+ appendChildNodes($('playfield'), image);
+ board[x][y].letterNode = image;
+ board[x][y].letter = letter;
+}
+
+function removeLastLetterFromMove() {
+}
+
+function letterAt(x, y) {
+ return board[x][y].letter && !board[x][y].justPlaced;
+}
+
+function Cursor()
+{
+ var image = new IMG({ src: 'images/cursor.png' });
+ image.style.position = 'absolute';
+ image.style.top = '-' + tileBorderSize + 'px';
+ image.style.left = '-' + tileBorderSize + 'px';
+
+ appendChildNodes($('playfield'), image);
+ this.image = image;
+ this.x = -1;
+ this.y = -1;
+ this.direction = 0;
+
+ this.set = function(x, y) {
+ this.x = x;
+ this.y = y;
+ this.image.top =
+ this.image.style.visibility = 'visible';
+ board[x][y].cursor = this.image;
+ };
+
+ this.clear = function() {
+ if (this.x != -1) {
+ this.image.style.visibility = 'hidden';
+ board[this.x][this.y].cursor = undefined;
+ this.x = this.y = -1;
+ this.direction = 0;
+ }
+ };
+
+ this.advance = function(isHoriz) {
+ var horizontal = 1;
+ var vertical = 2;
+ var direction = this.direction;
+ if (direction == 0) {
+ // Direction not determined
+ if (isHoriz != undefined) {
+ direction = isHoriz ? horizontal : vertical;
+ } else if (((this.y < 14) && letterAt(this.x, this.y + 1))
+ || ((this.y > 1)
+ && letterAt(this.x, this.y - 1)
+ && !letterAt(this.x, this.y - 2))
+ || ((this.x > 1)
+ && letterAt(this.x - 1, this.y)
+ && letterAt(this.x - 2, this.y))) {
+ direction = vertical;
+ } else {
+ direction = horizontal;
+ }
+ }
+ var x = this.x;
+ var y = this.y;
+ this.clear();
+ this.direction = direction;
+ if (this.direction == horizontal) {
+ x++;
+ } else {
+ y++;
+ }
+ if ((x != 15) && (y != 15)) {
+ this.set(x, y);
+ }
+ };
+}
+
+var cursor = new Cursor;
+
+function emptyTileClicked() {
+ cursor.clear();
+ cursor.set(this.xPos, this.yPos);
+}
+
+var move = [];
+
+function makeMask()
+{
+ var mask = IMG({ src: 'images/mask.png'});
+ mask.style.position = 'absolute';
+ mask.style.top = tileBorderSize + 'px';
+ mask.style.left = tileBorderSize + 'px';
+ mask.style.zIndex = '20';
+ return mask;
+}
+
+function addLetterToMove(x, y, tile) {
+ mask = makeMask();
+ appendChildNodes(board[x][y], mask);
+ board[x][y].letterNode = tile;
+ board[x][y].letter = tile.letter;
+ board[x][y].justPlaced = true;
+ tile.mask = mask;
+ tile.anim = new YAHOO.util.Motion(tile, { points: { to: [ border + x * cellSize + tileBorderSize,
+ border + y * cellSize + tileBorderSize ]}},
+ 0.15,
+ YAHOO.util.Easing.easeBoth);
+ tile.anim.animate();
+
+ move[move.length] = { x: x, y: y, tile: tile };
+ try {
+ checkMoveLegality(move);
+ $('move').onclick = submitMove;
+ $('move').innerHTML = "submit move";
+ displayStatus('');
+ }
+ catch (e) {
+ if (typeof e != 'string') {
+ alert(e.message);
+ } else {
+ displayStatus(e);
+ }
+ $('move').onclick = undefined;
+ $('move').innerHTML = e.toString();
+ }
+}
+
+function confirmMove() {
+ for (var i = 0; i < move.length; i++) {
+ removeElement(move[i].tile.mask);
+ move[i].tile.mask = undefined;
+ }
+ cursor.clear();
+ move = [];
+ $('move').onclick = null;
+ $('move').innerHTML = '';
+
+}
+
+function moveAsString() {
+ // We internally keep the move as array of objects, but send it to the server rather unstructured:
+ var serverMessage = [];
+ for (var i = 0; i < move.length; i++) {
+ serverMessage.push(move[i].x);
+ serverMessage.push(move[i].y);
+ serverMessage.push(move[i].tile.letterName);
+ serverMessage.push(move[i].tile.letterName == undefined);
+ }
+ return serverMessage.toString();
+}
+
+function submitMove()
+{
+ var queryString = MochiKit.Base.queryString({ move: moveAsString(), game: gameID });
+ var res = MochiKit.Async.doXHR("/place-tiles",
+ { method: 'POST',
+ sendContent: queryString,
+ headers: { "Content-Type": "application/x-www-form-urlencoded" } });
+ res.addCallbacks(moveSuccess, moveFailure);
+}
+
+function moveSuccess(result)
+{
+ try {
+ var response;
+ try {
+ response = eval('(' + result.responseText + ')');
+ }
+ catch (e) {
+ alert("invalid JSON reply: " + result.responseText);
+ return;
+ }
+ if (response.error) {
+ alert(response.error);
+ } else {
+ confirmMove();
+ $('playfield')['score-' + response.move.participantLogin].innerHTML = response.move.playerScore.toString();
+ displayMyTray(response.tray);
+ }
+ }
+ catch (e) {
+ alert('error during moveSuccess: ' + e.message);
+ }
+}
+
+function moveFailure(e)
+{
+ alert('failed: ' + e);
+}
+
+function letterKeyPressed(e) {
+ if (e.which == 0 || e.altKey || e.ctrlKey || e.shiftKey) {
+ // not a letter key
+ return;
+ }
+
+ var letter = String.fromCharCode(e.which).toUpperCase();
+
+ var x = cursor.x;
+ var y = cursor.y;
+ var tilePosition = -1;
+ for (var i = 0; (tilePosition == -1) && (i < tray.length); i++) {
+ if (tray[i].letter == letter) {
+ tilePosition = i;
+ }
+ }
+ if (tilePosition == -1) {
+ for (var i = 0; (tilePosition == -1) && (i < tray.length); i++) {
+ if (tray[i].letter == undefined) {
+ tilePosition = i;
+ }
+ }
+ }
+ if (tilePosition == -1) {
+ displayStatus('you-dont-have-that-letter', letter);
+ } else {
+ var isHoriz;
+ if (move.length > 0) {
+ isHoriz = (move[0].x != x);
+ }
+ cursor.advance(isHoriz);
+ if (!letterAt(x, y)) {
+ var tile = tray[tilePosition];
+ tray.splice(tilePosition, 1);
+ addLetterToMove(x, y, tile);
+ }
+ }
+}
+
+var leftKey = 37;
+var upKey = 38;
+var rightKey = 39;
+var downKey = 40;
+var backspaceKey = 8;
+
+function functionKeyPressed(type, args, obj) {
+ var x = cursor.x;
+ var y = cursor.y;
+
+ switch (args[0]) {
+ case rightKey:
+ while (x < 14)
+ if (!letterAt(++x, y))
+ break;
+ break;
+ case leftKey:
+ while (x > 0)
+ if (!letterAt(--x, y))
+ break;
+ break;
+ case upKey:
+ while (y > 0)
+ if (!letterAt(x, --y))
+ break;
+ break;
+ case downKey:
+ while (y < 14)
+ if (!letterAt(x, ++y))
+ break;
+ break;
+ case backspaceKey:
+ if (move.length) {
+ removeLastLetterFromMove();
+ }
+ }
+ if ((x >= 0) && (x <= 14) && (y >= 0) && (y <= 14)) {
+ cursor.clear();
+ cursor.set(x, y);
+ }
+ YAHOO.util.Event.preventDefault(args[1]);
+}
+
+function clearBoard() {
+ for (x = 0; x < 15; x++) {
+ for (y = 0; y < 15; y++) {
+ var letterNode = board[x][y].letterNode;
+ if (letterNode) {
+ letterNode.anim = new YAHOO.util.Motion(letterNode,
+ { points: { to: [ border + 7 * cellSize + tileBorderSize,
+ border + 7 * cellSize + tileBorderSize ]}},
+ 0.15);
+ letterNode.anim.onComplete.subscribe(function () { removeElement(this); });
+ letterNode.anim.animate();
+ }
+ }
+ }
+}
+
+function trayClick(letter) {
+ this.clicked = !this.clicked;
+ this.anim = new YAHOO.util.Motion(this, { points: { by: [ 0, (this.clicked ? 15 : -15 ) ]}}, 0.15);
+ this.anim.animate();
+}
+
+function displayMyTray(letters) {
+ map(removeElement, tray);
+ tray = [];
+ for (var i = 0; i < letters.length; i++) {
+ var element = IMG({src: 'images/' + letters[i].letterName + '.png'});
+ element.letter = letters[i].letter;
+ element.letterName = letters[i].letterName;
+ element.style.position = 'absolute';
+ element.style.width = tileSize + 'px';
+ element.style.height = tileSize + 'px';
+ element.style.zIndex = '10';
+ element.onclick = trayClick;
+ setElementPosition(element, { x: border + i * fieldSize,
+ y: border + 15 * cellSize + 10 });
+ tray[i] = element;
+ }
+ appendChildNodes($('playfield'), tray);
+}
+
+function shuffleMyTray() {
+ var count = tray.length;
+ var newTray = [];
+ for (var i = 0; i < count; i++) {
+ do {
+ index = Math.floor(Math.random() * count);
+ } while (newTray[index]);
+ newTray[index] = tray[i];
+ newTray[index].anim = new YAHOO.util.Motion(tray[i], { points: { to: [ border + 194 + i * 40,
+ border + 665 ] }},
+ 0.5);
+ newTray[index].anim.animate();
+ newTray[index].clicked = false;
+ }
+ tray = newTray;
+}
+
+var otherPlayerIndex = 0;
+
+function makeTheirTray (participant) {
+ var tileCount = (typeof participant.remainingTiles == 'number') ? participant.remainingTiles : participant.remainingTiles.length;
+
+ var tray = [];
+ for (var i = 0; i < tileCount; i++) {
+ var element = IMG({src: 'images/null.png'});
+ element.style.position = 'absolute';
+ element.style.width = tileSize + 'px';
+ element.style.height = tileSize + 'px';
+ element.style.zIndex = '10';
+ setElementPosition(element, { x: border + 15 * cellSize + 10 + i * fieldSize,
+ y: border + 80 * otherPlayerIndex });
+ tray[i] = element;
+ }
+ appendChildNodes($('playfield'), tray);
+
+ var nameTag = DIV(null, participant.name);
+ nameTag.style.position = 'absolute';
+ nameTag.style.width = '200px';
+ nameTag.style.textAlign = 'left';
+ setElementPosition(nameTag, { x: border + 680, y: border + 80 * otherPlayerIndex + 50 });
+ appendChildNodes($('playfield'), nameTag);
+
+ var scoreTag = DIV(null, participant.score);
+ scoreTag.style.position = 'absolute';
+ scoreTag.style.width = '80px';
+ scoreTag.style.textAlign = 'right';
+ setElementPosition(scoreTag, { x: border + 870, y: border + 80 * otherPlayerIndex + 50 });
+ appendChildNodes($('playfield'), scoreTag);
+ $('playfield')['score-' + participant.login] = scoreTag;
+
+ otherPlayerIndex++;
+}
+
+function renderMoveAsText(move)
+{
+ var retval = move.participantLogin;
+ if (move.type == 'move') {
+ retval += " score: " + move.score;
+ for (var i = 0; i < move.words.length; i++) {
+ retval += " " + move.words[i][0] + "(" + move.words[i][1] + ")";
+ }
+ } else {
+ retval += move.type;
+ }
+
+ return retval;
+}
+
+function displayWhosTurnItIs(name) {
+ replaceChildNodes($('nextTurn'),
+ "Next: " + name);
+}
+
+function drawGameState (gameState) {
+ try {
+ for (var i = 0; i < gameState.board.length; i++) {
+ var x = gameState.board[i][0];
+ var y = gameState.board[i][1];
+ var char = gameState.board[i][2];
+ setLetter(x, y, char, gameState.board[i].length > 3);
+ }
+ var firstParticipant = gameState.participants[0];
+ displayWhosTurnItIs(firstParticipant.name);
+ for (var i = 0; i < gameState.participants.length; i++) {
+ var participant = gameState.participants[i];
+ makeTheirTray(participant);
+ if (typeof participant.remainingTiles != 'number') {
+ displayMyTray(participant.remainingTiles);
+ }
+ }
+ for (var i = 0; i < gameState.moves.length; i++) {
+ appendChildNodes($('gameLog'), DIV(null, renderMoveAsText(gameState.moves[i])));
+ }
+ }
+ catch (e) {
+ alert('error ' + e + ' in drawGameState');
+ }
+}
+
+function displayStatus(status)
+{
+ replaceChildNodes('status', status);
+}
+
+function init() {
+ makeBoard();
+
+ // does not work for ie (document.body needed)?
+ YAHOO.util.Event.on(window, 'keypress', letterKeyPressed);
+
+ var functionKeyListener = new YAHOO.util.KeyListener(document,
+ { keys: [ leftKey, upKey, rightKey, downKey, backspaceKey ] },
+ { fn: functionKeyPressed, scope: this, correctScope: true });
+ functionKeyListener.enable();
+
+ var moveDisplay = DIV({ id: 'move' }, "");
+ moveDisplay.style.color = 'white';
+ moveDisplay.style.position = 'absolute';
+ setElementPosition(moveDisplay, { x: border + 550, y: border + 665 });
+ appendChildNodes(document.body, moveDisplay);
+ var d = loadJSONDoc("/game/" + gameID);
+ d.addCallbacks(drawGameState, function (error) { alert("Request error: " + error.message); });
+}
Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.html
==============================================================================
--- branches/trunk-reorg/projects/scrabble/website/scrabble.html (original)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble.html Thu Jan 17 11:36:28 2008
@@ -1,18 +1,18 @@
<html>
- <head>
- <link rel="stylesheet" type="text/css" href="/yui/reset-fonts-grids/reset-fonts-grids.css" />
- <link rel="stylesheet" type="text/css" href="scrabble.css" />
- <script type="text/javascript" src="/yui/yahoo/yahoo-min.js"> </script>
- <script type="text/javascript" src="/yui/event/event-min.js"> </script>
- <script type="text/javascript" src="/yui/dom/dom-min.js"> </script>
- <script type="text/javascript" src="/yui/animation/animation-min.js"> </script>
- <script type="text/javascript" src="/MochiKit/MochiKit.js"> </script>
- <script type="text/javascript" src="scrabble.js"> </script>
- </head>
- <body onload="init()">
- <div id="playfield">
- </div>
- <!-- <div style="position: absolute; right: 20px; top: 20px;"><a style="color: white;" href="/login?login=hans">hans</a></div> -->
- <!-- <div style="position: absolute; right: 20px; top: 40px;"><a style="color: white;" href="/login?login=marna">marna</a></div> -->
- </body>
+ <head>
+ <link rel="stylesheet" type="text/css" href="/yui/reset-fonts-grids/reset-fonts-grids.css" />
+ <link rel="stylesheet" type="text/css" href="scrabble.css" />
+ <script type="text/javascript" src="/yui/yahoo/yahoo-min.js"> </script>
+ <script type="text/javascript" src="/yui/event/event-min.js"> </script>
+ <script type="text/javascript" src="/yui/dom/dom-min.js"> </script>
+ <script type="text/javascript" src="/yui/animation/animation-min.js"> </script>
+ <script type="text/javascript" src="/MochiKit/MochiKit.js"> </script>
+ <script type="text/javascript" src="scrabble.js"> </script>
+ </head>
+ <body onload="init()">
+ <div id="playfield">
+ </div>
+ <div style="position: absolute; right: 20px; top: 20px;"><a style="color: white;" href="/login?login=hans">hans</a></div>
+ <div style="position: absolute; right: 20px; top: 40px;"><a style="color: white;" href="/login?login=marna">marna</a></div>
+ </body>
</html>
Modified: branches/trunk-reorg/projects/scrabble/website/scrabble.js
==============================================================================
--- branches/trunk-reorg/projects/scrabble/website/scrabble.js (original)
+++ branches/trunk-reorg/projects/scrabble/website/scrabble.js Thu Jan 17 11:36:28 2008
@@ -1,386 +1,380 @@
// -*- JavaScript -*-
-var boardScoring = [["triple-word",null,null,"double-letter",null,null,null,"triple-word",
- null,null,null,"double-letter",null,null,"triple-word"],
- [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter",
- null,null,null,"double-word",null],
- [null,null,"double-word",null,null,null,"double-letter",null,"double-letter",
- null,null,null,"double-word",null,null],
- ["double-letter",null,null,"double-word",null,null,null,"double-letter",
- null,null,null,"double-word",null,null,"double-letter"],
- [null,null,null,null,"double-word",null,null,null,null,null,"double-word",
- null,null,null,null],
- [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter",
- null,null,null,"triple-letter",null],
- [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter",
- null,null,null,"double-letter",null,null],
- ["triple-word",null,null,"double-letter",null,null,null,"double-word",
- null,null,null,"double-letter",null,null,"triple-word"],
- [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter",
- null,null,null,"double-letter",null,null],
- [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter",
- null,null,null,"triple-letter",null],
- [null,null,null,null,"double-word",null,null,null,null,null,"double-word",
- null,null,null,null],
- ["double-letter",null,null,"double-word",null,null,null,"double-letter",
- null,null,null,"double-word",null,null,"double-letter"],
- [null,null,"double-word",null,null,null,"double-letter",null,"double-letter",
- null,null,null,"double-word",null,null],
- [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter",
- null,null,null,"double-word",null],
- ["triple-word",null,null,"double-letter",null,null,null,"triple-word",
- null,null,null,"double-letter",null,null,"triple-word"]];
-
-// for now
-function requestError (error) {
- alert("Request error: " + error.message)
-}
+var scrabbleRules = {
+ boardScoring: [["triple-word",null,null,"double-letter",null,null,null,"triple-word",
+ null,null,null,"double-letter",null,null,"triple-word"],
+ [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"double-word",null],
+ [null,null,"double-word",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-word",null,null],
+ ["double-letter",null,null,"double-word",null,null,null,"double-letter",
+ null,null,null,"double-word",null,null,"double-letter"],
+ [null,null,null,null,"double-word",null,null,null,null,null,"double-word",
+ null,null,null,null],
+ [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"triple-letter",null],
+ [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-letter",null,null],
+ ["triple-word",null,null,"double-letter",null,null,null,"double-word",
+ null,null,null,"double-letter",null,null,"triple-word"],
+ [null,null,"double-letter",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-letter",null,null],
+ [null,"triple-letter",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"triple-letter",null],
+ [null,null,null,null,"double-word",null,null,null,null,null,"double-word",
+ null,null,null,null],
+ ["double-letter",null,null,"double-word",null,null,null,"double-letter",
+ null,null,null,"double-word",null,null,"double-letter"],
+ [null,null,"double-word",null,null,null,"double-letter",null,"double-letter",
+ null,null,null,"double-word",null,null],
+ [null,"double-word",null,null,null,"triple-letter",null,null,null,"triple-letter",
+ null,null,null,"double-word",null],
+ ["triple-word",null,null,"double-letter",null,null,null,"triple-word",
+ null,null,null,"double-letter",null,null,"triple-word"]],
-// Scrabble rule enforcement
+ // Scrabble rule enforcement
-function checkMoveLegality(placedTiles)
-{
+ checkMoveLegality : function (placedTiles) {
// Given the board and list of placed tiles, either throw an error or
// return if the move is legal.
var positions = map(function (placement) { return [ placement.x, placement.y ] }, placedTiles)
- .sort(function (a, b) { return (a[0] - b[0]) || (a[1] - b[1])});
+ .sort(function (a, b) { return (a[0] - b[0]) || (a[1] - b[1])});
if (filter(partial(operator.ne, positions[0][0]), map(function (position) { return position[0] }, positions)).length
- && filter(partial(operator.ne, positions[0][1]), map(function (position) { return position[1] }, positions)).length) {
- throw "not-in-a-row";
+ && filter(partial(operator.ne, positions[0][1]), map(function (position) { return position[1] }, positions)).length) {
+ throw "not-in-a-row";
}
var startOfPlacement = positions[0];
var endOfPlacement = positions[positions.length - 1];
for (var x = startOfPlacement[0]; x <= endOfPlacement[0]; x++) {
- for (var y = startOfPlacement[1]; y <= endOfPlacement[1]; y++) {
- if (!letterAt(x, y) && (findValue(positions, [ x, y ]) == -1)) {
- throw "placement-with-holes";
- }
- }
+ for (var y = startOfPlacement[1]; y <= endOfPlacement[1]; y++) {
+ if (!letterAt(x, y) && (findValue(positions, [ x, y ]) == -1)) {
+ throw "placement-with-holes";
+ }
+ }
}
if (findValue(positions, [ 7, 7 ]) == -1) {
- var found = false;
- for (var x = startOfPlacement[0]; !found && (x <= endOfPlacement[0]); x++) {
- for (var y = startOfPlacement[1]; !found && (y <= endOfPlacement[1]); y++) {
- if (((x > 0) && letterAt(x - 1, y))
- || ((x < 14) && letterAt(x + 1, y))
- || ((y > 0) && letterAt(x, y - 1))
- || ((y < 14) && letterAt(x, y + 1))) {
- found = true;
- }
- }
- }
- if (!found) {
- throw "not-touching-other-tile";
- }
+ var found = false;
+ for (var x = startOfPlacement[0]; !found && (x <= endOfPlacement[0]); x++) {
+ for (var y = startOfPlacement[1]; !found && (y <= endOfPlacement[1]); y++) {
+ if (((x > 0) && letterAt(x - 1, y))
+ || ((x < 14) && letterAt(x + 1, y))
+ || ((y > 0) && letterAt(x, y - 1))
+ || ((y < 14) && letterAt(x, y + 1))) {
+ found = true;
+ }
+ }
+ }
+ if (!found) {
+ throw "not-touching-other-tile";
+ }
}
-}
+ },
-//
+ //
-function getFieldScore(x, y) {
+ fieldScore : function(x, y) {
return boardScoring[x][y] || 'standard';
-}
+ }
+};
var theirTrays;
var tray = [];
+var gameID = 108;
var board;
-var border = 10;
-
function makeBoard() {
- var container = $('playfield');
- board = [];
- for (x = 0; x < 15; x++) {
- board[x] = [];
- for (y = 0; y < 15; y++) {
- var element = DIV();
- element.style.position = 'absolute';
- element.style.width = '40px';
- element.style.height = '40px';
- var imageName = (x == 7 && y == 7) ? "start-field" : getFieldScore(x, y);
- element.style.backgroundImage = 'url(images/' + imageName + '.png)';
- element.x = x;
- element.y = y;
- setElementPosition(element, { x: border + x * 44, y: border + y * 44 });
- YAHOO.util.Event.on(element, 'click', emptyTileClicked)
- board[x][y] = element;
- }
- appendChildNodes(container, board[x]);
- }
-
- var shuffleButton = DIV(null, "shuffle");
- shuffleButton.style.color = 'white';
- shuffleButton.style.position = 'absolute';
- shuffleButton.onclick = shuffleMyTray;
- setElementPosition(shuffleButton, { x: border + 480, y: border + 665 });
- appendChildNodes(container, shuffleButton);
-
- var gameLog = DIV({ id: 'gameLog' }, "");
- gameLog.style.position = 'absolute';
- gameLog.style.width = '280px';
- gameLog.style.height = '250px';
- gameLog.style.textAlign = 'left';
- gameLog.style.overflowY = 'scroll';
- setElementPosition(gameLog, { x: border + 680, y: border + 400 });
- appendChildNodes($('playfield'), gameLog);
-
- var nextTurn = DIV({ id: 'nextTurn' }, "");
- nextTurn.style.position = 'absolute';
- nextTurn.style.width = '280px';
- nextTurn.style.textAlign = 'left';
- setElementPosition(nextTurn, { x: border + 680, y: border + 665 });
- appendChildNodes($('playfield'), nextTurn);
-
- var nextTurn = DIV({ id: 'status' }, "");
- nextTurn.style.position = 'absolute';
- nextTurn.style.width = '280px';
- nextTurn.style.textAlign = 'left';
- setElementPosition(nextTurn, { x: border + 680, y: border + 680 });
- appendChildNodes($('playfield'), nextTurn);
+ var container = $('playfield');
+ board = [];
+ for (x = 0; x < 15; x++) {
+ board[x] = [];
+ for (y = 0; y < 15; y++) {
+ var element = DIV();
+ element.style.position = 'absolute';
+ element.style.width = '40px';
+ element.style.height = '40px';
+ var imageName = (x == 7 && y == 7) ? "start-field" : scrabbleRules.fieldScore(x, y);
+ element.style.backgroundImage = 'url(images/' + imageName + '.png)';
+ element.x = x;
+ element.y = y;
+ setElementPosition(element, { x: x * 44, y: y * 44 });
+ YAHOO.util.Event.on(element, 'click', emptyTileClicked)
+ board[x][y] = element;
+ }
+ appendChildNodes(container, board[x]);
+ }
+
+ var shuffleButton = DIV(null, "shuffle");
+ shuffleButton.style.color = 'white';
+ shuffleButton.style.position = 'absolute';
+ shuffleButton.onclick = shuffleMyTray;
+ setElementPosition(shuffleButton, { x: 480, y: 665 });
+ appendChildNodes(container, shuffleButton);
+
+ var gameLog = DIV({ id: 'gameLog' }, "");
+ gameLog.style.position = 'absolute';
+ gameLog.style.width = '280px';
+ gameLog.style.height = '250px';
+ gameLog.style.textAlign = 'left';
+ gameLog.style.overflowY = 'scroll';
+ setElementPosition(gameLog, { x: 680, y: 400 });
+ appendChildNodes($('playfield'), gameLog);
+
+ var nextTurn = DIV({ id: 'nextTurn' }, "");
+ nextTurn.style.position = 'absolute';
+ nextTurn.style.width = '280px';
+ nextTurn.style.textAlign = 'left';
+ setElementPosition(nextTurn, { x: 680, y: 665 });
+ appendChildNodes($('playfield'), nextTurn);
+
+ var nextTurn = DIV({ id: 'status' }, "");
+ nextTurn.style.position = 'absolute';
+ nextTurn.style.width = '280px';
+ nextTurn.style.textAlign = 'left';
+ setElementPosition(nextTurn, { x: 680, y: 680 });
+ appendChildNodes($('playfield'), nextTurn);
}
function setLetter(x, y, letter, isBlank) {
- var image = IMG({ src: 'images/' + letter + (isBlank ? "-blank" : "") + '.png'});
- image.style.position = 'absolute';
- image.style.top = '3px';
- image.style.left = '3px';
- setElementPosition(image, { x: border + x * 44 + 3, y: border + y * 44 + 3 });
- appendChildNodes($('playfield'), image);
- board[x][y].letterNode = image;
- board[x][y].letter = letter;
-}
-
-function placeLetter(x, y, tile) {
+ var image = IMG({ src: 'images/' + letter + (isBlank ? "-blank" : "") + '.png'});
+ image.style.position = 'absolute';
+ image.style.top = '3px';
+ image.style.left = '3px';
+ setElementPosition(image, { x: x * 44 + 3, y: y * 44 + 3 });
+ appendChildNodes($('playfield'), image);
+ board[x][y].letterNode = image;
+ board[x][y].letter = letter;
}
function removeLastLetterFromMove() {
}
function letterAt(x, y) {
- return board[x][y].letter && !board[x][y].justPlaced;
+ return board[x][y].letter && !board[x][y].justPlaced;
}
function Cursor()
{
- var image = new IMG({ src: 'images/cursor.png' });
- image.style.position = 'absolute';
- image.style.top = '-3px';
- image.style.left = '-3px';
-
- this.image = image;
- this.x = -1;
- this.y = -1;
- this.direction = 0;
-
- this.set = function(x, y) {
- this.x = x;
- this.y = y;
- appendChildNodes(board[x][y], this.image);
- board[x][y].cursor = this.image;
- };
-
- this.clear = function() {
- if (this.x != -1) {
- removeElement(board[this.x][this.y].cursor);
- board[this.x][this.y].cursor = undefined;
- this.x = this.y = -1;
- this.direction = 0;
- }
- };
-
- this.advance = function(isHoriz) {
- var horizontal = 1;
- var vertical = 2;
- var direction = this.direction;
- if (direction == 0) {
- // Direction not determined
- if (isHoriz != undefined) {
- direction = isHoriz ? horizontal : vertical;
- } else if (((this.y < 14) && letterAt(this.x, this.y + 1))
- || ((this.y > 1)
- && letterAt(this.x, this.y - 1)
- && !letterAt(this.x, this.y - 2))
- || ((this.x > 1)
- && letterAt(this.x - 1, this.y)
- && letterAt(this.x - 2, this.y))) {
- direction = vertical;
- } else {
- direction = horizontal;
- }
- }
- var x = this.x;
- var y = this.y;
- this.clear();
- this.direction = direction;
- if (this.direction == horizontal) {
- x++;
- } else {
- y++;
- }
- if ((x != 15) && (y != 15)) {
- this.set(x, y);
- }
- };
+ var image = new IMG({ src: 'images/cursor.png' });
+ image.style.position = 'absolute';
+ image.style.top = '-3px';
+ image.style.left = '-3px';
+
+ this.image = image;
+ this.x = -1;
+ this.y = -1;
+ this.direction = 0;
+
+ this.set = function(x, y) {
+ this.x = x;
+ this.y = y;
+ appendChildNodes(board[x][y], this.image);
+ board[x][y].cursor = this.image;
+ };
+
+ this.clear = function() {
+ if (this.x != -1) {
+ removeElement(board[this.x][this.y].cursor);
+ board[this.x][this.y].cursor = undefined;
+ this.x = this.y = -1;
+ this.direction = 0;
+ }
+ };
+
+ this.advance = function(isHoriz) {
+ var horizontal = 1;
+ var vertical = 2;
+ var direction = this.direction;
+ if (direction == 0) {
+ // Direction not determined
+ if (isHoriz != undefined) {
+ direction = isHoriz ? horizontal : vertical;
+ } else if (((this.y < 14) && letterAt(this.x, this.y + 1))
+ || ((this.y > 1)
+ && letterAt(this.x, this.y - 1)
+ && !letterAt(this.x, this.y - 2))
+ || ((this.x > 1)
+ && letterAt(this.x - 1, this.y)
+ && letterAt(this.x - 2, this.y))) {
+ direction = vertical;
+ } else {
+ direction = horizontal;
+ }
+ }
+ var x = this.x;
+ var y = this.y;
+ this.clear();
+ this.direction = direction;
+ if (this.direction == horizontal) {
+ x++;
+ } else {
+ y++;
+ }
+ if ((x != 15) && (y != 15)) {
+ this.set(x, y);
+ }
+ };
}
var cursor = new Cursor;
function emptyTileClicked() {
- cursor.clear();
- cursor.set(this.x, this.y);
+ cursor.clear();
+ cursor.set(this.x, this.y);
}
var move = [];
function makeMask()
{
- var mask = IMG({ src: 'images/mask.png'});
- mask.style.position = 'absolute';
- mask.style.top = '3px';
- mask.style.left = '3px';
- mask.style.zIndex = '20';
- return mask;
-}
-
-function addLetterToMove(x, y, tile) {
- mask = makeMask();
- appendChildNodes(board[x][y], mask);
- board[x][y].letterNode = tile;
- board[x][y].letter = tile.letter;
- board[x][y].justPlaced = true;
- tile.mask = mask;
- tile.anim = new YAHOO.util.Motion(tile, { points: { to: [ border + x * 44 + 3,
- border + y * 44 + 3 ]}},
- 0.15,
- YAHOO.util.Easing.easeBoth);
- tile.anim.animate();
-
- move[move.length] = { x: x, y: y, tile: tile };
- try {
- checkMoveLegality(move);
- $('move').onclick = submitMove;
- $('move').innerHTML = "submit move";
- displayStatus('');
- }
- catch (e) {
- if (typeof e != 'string') {
- alert(e.message);
- } else {
- displayStatus(e);
- }
- $('move').onclick = undefined;
- $('move').innerHTML = e.toString();
+ var mask = IMG({ src: 'images/mask.png'});
+ mask.style.position = 'absolute';
+ mask.style.top = '3px';
+ mask.style.left = '3px';
+ mask.style.zIndex = '20';
+ return mask;
+}
+
+function addLetterToMove(x, y, tile, letter) {
+ mask = makeMask();
+ appendChildNodes(board[x][y], mask);
+ board[x][y].letterNode = tile;
+ if (!tile.letter) {
+ tile.letter = letter;
+ }
+ board[x][y].justPlaced = true;
+ tile.mask = mask;
+ tile.anim = new YAHOO.util.Motion(tile, { points: { to: [ x * 44 + 3,
+ y * 44 + 3 ]}},
+ 0.15,
+ YAHOO.util.Easing.easeBoth);
+ tile.anim.animate();
+
+ move[move.length] = { x: x, y: y, tile: tile };
+ try {
+ checkMoveLegality(move);
+ $('move').onclick = submitMove;
+ $('move').innerHTML = "submit move";
+ displayStatus('');
+ }
+ catch (e) {
+ if (typeof e != 'string') {
+ alert(e.message);
+ } else {
+ displayStatus(e);
}
+ $('move').onclick = undefined;
+ $('move').innerHTML = e.toString();
+ }
}
function confirmMove() {
- for (var i = 0; i < move.length; i++) {
- removeElement(move[i].tile.mask);
- move[i].tile.mask = undefined;
- }
- cursor.clear();
- move = [];
- $('move').onclick = null;
- $('move').innerHTML = '';
-
+ for (var i = 0; i < move.length; i++) {
+ removeElement(move[i].tile.mask);
+ move[i].tile.mask = undefined;
+ }
+ cursor.clear();
+ move = [];
+ $('move').onclick = null;
+ $('move').innerHTML = '';
+
}
function moveAsString() {
- // We internally keep the move as array of objects, but send it to the server rather unstructured:
- var serverMessage = [];
- for (var i = 0; i < move.length; i++) {
- serverMessage.push(move[i].x);
- serverMessage.push(move[i].y);
- serverMessage.push(move[i].tile.letterName);
- serverMessage.push(move[i].tile.letterName == undefined);
- }
- return serverMessage.toString();
+ // We internally keep the move as array of objects, but send it to the server rather unstructured:
+ var serverMessage = [];
+ for (var i = 0; i < move.length; i++) {
+ serverMessage.push(move[i].x);
+ serverMessage.push(move[i].y);
+ serverMessage.push(move[i].tile.letterName || move[i].tile.letter);
+ serverMessage.push(move[i].tile.letterName == undefined);
+ }
+ return serverMessage.toString();
}
function submitMove()
{
- var queryString = MochiKit.Base.queryString({ move: moveAsString() });
- var res = MochiKit.Async.doXHR("/place-tiles",
- { method: 'POST',
+ var queryString = MochiKit.Base.queryString({ move: moveAsString(), game: gameID });
+ var res = MochiKit.Async.doXHR("/place-tiles",
+ { method: 'POST',
sendContent: queryString,
headers: { "Content-Type": "application/x-www-form-urlencoded" } });
- res.addCallbacks(moveSuccess, moveFailure);
+ res.addCallbacks(moveSuccess, moveFailure);
}
function moveSuccess(result)
{
+ try {
+ var response;
try {
- var response;
- try {
- response = eval('(' + result.responseText + ')');
- }
- catch (e) {
- alert("invalid JSON reply: " + result.responseText);
- return;
- }
- if (response.error) {
- alert(response.error);
- } else {
- confirmMove();
- alert(response.move.playerScore);
- $('playfield')['score-' + response.move.participantLogin].innerHTML = response.move.playerScore.toString();
- displayMyTray(response.tray);
- }
+ response = eval('(' + result.responseText + ')');
}
catch (e) {
- alert('error during moveSuccess: ' + e.message);
+ alert("invalid JSON reply: " + result.responseText);
+ return;
}
+ if (response.error) {
+ alert(response.error);
+ } else {
+ confirmMove();
+ alert(response.move.playerScore);
+ $('playfield')['score-' + response.move.participantLogin].innerHTML = response.move.playerScore.toString();
+ displayMyTray(response.tray);
+ }
+ }
+ catch (e) {
+ alert('error during moveSuccess: ' + e.message);
+ }
}
function moveFailure(e)
{
- alert('failed: ' + e);
+ alert('failed: ' + e);
}
function letterKeyPressed(e) {
- if (e.which == 0 || e.altKey || e.ctrlKey || e.shiftKey) {
- // not a letter key
- return;
+ if (e.which == 0 || e.altKey || e.ctrlKey || e.shiftKey) {
+ // not a letter key
+ return;
+ }
+
+ var letter = String.fromCharCode(e.which).toUpperCase();
+
+ var x = cursor.x;
+ var y = cursor.y;
+ var tilePosition = -1;
+ for (var i = 0; (tilePosition == -1) && (i < tray.length); i++) {
+ if (tray[i].letter == letter) {
+ tilePosition = i;
}
-
- var letter = String.fromCharCode(e.which).toUpperCase();
-
- var x = cursor.x;
- var y = cursor.y;
- var tilePosition = -1;
+ }
+ if (tilePosition == -1) {
for (var i = 0; (tilePosition == -1) && (i < tray.length); i++) {
- if (tray[i].letter == letter) {
- tilePosition = i;
- }
- }
- if (tilePosition == -1) {
- for (var i = 0; (tilePosition == -1) && (i < tray.length); i++) {
- if (tray[i].letter == undefined) {
- tilePosition = i;
- }
- }
- }
- if (tilePosition == -1) {
- displayStatus('you-dont-have-that-letter', letter);
- } else {
- var isHoriz;
- if (move.length > 0) {
- isHoriz = (move[0].x != x);
- }
- cursor.advance(isHoriz);
- if (!letterAt(x, y)) {
- var tile = tray[tilePosition];
- tray.splice(tilePosition, 1);
- addLetterToMove(x, y, tile);
- }
+ if (tray[i].letter == undefined) {
+ tilePosition = i;
+ }
+ }
+ }
+ if (tilePosition == -1) {
+ displayStatus('you-dont-have-that-letter', letter);
+ } else {
+ var isHoriz;
+ if (move.length > 0) {
+ isHoriz = (move[0].x != x);
+ }
+ cursor.advance(isHoriz);
+ if (!letterAt(x, y)) {
+ var tile = tray[tilePosition];
+ tray.splice(tilePosition, 1);
+ addLetterToMove(x, y, tile, letter);
}
+ }
}
var leftKey = 37;
@@ -390,439 +384,200 @@
var backspaceKey = 8;
function functionKeyPressed(type, args, obj) {
- var x = cursor.x;
- var y = cursor.y;
+ var x = cursor.x;
+ var y = cursor.y;
- switch (args[0]) {
- case rightKey:
- while (x < 14)
- if (!letterAt(++x, y))
- break;
- break;
- case leftKey:
- while (x > 0)
- if (!letterAt(--x, y))
- break;
- break;
- case upKey:
- while (y > 0)
- if (!letterAt(x, --y))
- break;
- break;
- case downKey:
- while (y < 14)
- if (!letterAt(x, ++y))
- break;
- break;
- case backspaceKey:
- if (move.length) {
- removeLastLetterFromMove();
- }
- }
- if ((x >= 0) && (x <= 14) && (y >= 0) && (y <= 14)) {
- cursor.clear();
- cursor.set(x, y);
+ switch (args[0]) {
+ case rightKey:
+ while (x < 14)
+ if (!letterAt(++x, y))
+ break;
+ break;
+ case leftKey:
+ while (x > 0)
+ if (!letterAt(--x, y))
+ break;
+ break;
+ case upKey:
+ while (y > 0)
+ if (!letterAt(x, --y))
+ break;
+ break;
+ case downKey:
+ while (y < 14)
+ if (!letterAt(x, ++y))
+ break;
+ break;
+ case backspaceKey:
+ if (move.length) {
+ removeLastLetterFromMove();
}
- YAHOO.util.Event.preventDefault(args[1]);
+ }
+ if ((x >= 0) && (x <= 14) && (y >= 0) && (y <= 14)) {
+ cursor.clear();
+ cursor.set(x, y);
+ }
+ YAHOO.util.Event.preventDefault(args[1]);
}
function clearBoard() {
- for (x = 0; x < 15; x++) {
- for (y = 0; y < 15; y++) {
- var letterNode = board[x][y].letterNode;
- if (letterNode) {
- letterNode.anim = new YAHOO.util.Motion(letterNode, { points: { to: [ border + 7 * 44 + 3,
- border + 7 * 44 + 3 ]}},
- 0.15);
- letterNode.anim.onComplete.subscribe(function () { removeElement(this); });
- letterNode.anim.animate();
- }
- }
+ for (x = 0; x < 15; x++) {
+ for (y = 0; y < 15; y++) {
+ var letterNode = board[x][y].letterNode;
+ if (letterNode) {
+ letterNode.anim = new YAHOO.util.Motion(letterNode, { points: { to: [ 7 * 44 + 3,
+ 7 * 44 + 3 ]}},
+ 0.15);
+ letterNode.anim.onComplete.subscribe(function () { removeElement(this); });
+ letterNode.anim.animate();
+ }
}
+ }
}
function trayClick(letter) {
- this.clicked = !this.clicked;
- this.anim = new YAHOO.util.Motion(this, { points: { by: [ 0, (this.clicked ? 15 : -15 ) ]}}, 0.15);
- this.anim.animate();
+ this.clicked = !this.clicked;
+ this.anim = new YAHOO.util.Motion(this, { points: { by: [ 0, (this.clicked ? 15 : -15 ) ]}}, 0.15);
+ this.anim.animate();
}
function displayMyTray(letters) {
- map(removeElement, tray);
- tray = [];
- for (var i = 0; i < letters.length; i++) {
- var element = IMG({src: 'images/' + letters[i].letterName + '.png'});
- element.letter = letters[i].letter;
- element.letterName = letters[i].letterName;
- element.style.position = 'absolute';
- element.style.width = '34px';
- element.style.height = '34px';
- element.style.zIndex = '10';
- element.onclick = trayClick;
- setElementPosition(element, { x: border + i * 40, y: border + 665 });
- tray[i] = element;
- }
- appendChildNodes($('playfield'), tray);
+ map(removeElement, tray);
+ tray = [];
+ for (var i = 0; i < letters.length; i++) {
+ var element = IMG({src: 'images/' + letters[i].letterName + '.png'});
+ element.letter = letters[i].letter;
+ element.letterName = letters[i].letterName;
+ element.style.position = 'absolute';
+ element.style.width = '34px';
+ element.style.height = '34px';
+ element.style.zIndex = '10';
+ element.onclick = trayClick;
+ setElementPosition(element, { x: i * 40, y: 665 });
+ tray[i] = element;
+ }
+ appendChildNodes($('playfield'), tray);
}
function shuffleMyTray() {
- var count = tray.length;
- var newTray = [];
- for (var i = 0; i < count; i++) {
- do {
- index = Math.floor(Math.random() * count);
- } while (newTray[index]);
- newTray[index] = tray[i];
- newTray[index].anim = new YAHOO.util.Motion(tray[i], { points: { to: [ border + 194 + i * 40,
- border + 665 ] }},
- 0.5);
- newTray[index].anim.animate();
- newTray[index].clicked = false;
- }
- tray = newTray;
+ var count = tray.length;
+ var newTray = [];
+ for (var i = 0; i < count; i++) {
+ do {
+ index = Math.floor(Math.random() * count);
+ } while (newTray[index]);
+ newTray[index] = tray[i];
+ newTray[index].anim = new YAHOO.util.Motion(tray[i], { points: { to: [ 194 + i * 40,
+ 665 ] }},
+ 0.5);
+ newTray[index].anim.animate();
+ newTray[index].clicked = false;
+ }
+ tray = newTray;
}
var otherPlayerIndex = 0;
function makeTheirTray (participant) {
- var tileCount = (typeof participant.remainingTiles == 'number') ? participant.remainingTiles : participant.remainingTiles.length;
+ var tileCount = (typeof participant.remainingTiles == 'number') ? participant.remainingTiles : participant.remainingTiles.length;
- var tray = [];
- for (var i = 0; i < tileCount; i++) {
- var element = IMG({src: 'images/null.png'});
- element.style.position = 'absolute';
- element.style.width = '34px';
- element.style.height = '34px';
- element.style.zIndex = '10';
- setElementPosition(element, { x: border + 680 + i * 40, y: border + 80 * otherPlayerIndex });
- tray[i] = element;
- }
- appendChildNodes($('playfield'), tray);
-
- var nameTag = DIV(null, participant.name);
- nameTag.style.position = 'absolute';
- nameTag.style.width = '200px';
- nameTag.style.textAlign = 'left';
- setElementPosition(nameTag, { x: border + 680, y: border + 80 * otherPlayerIndex + 50 });
- appendChildNodes($('playfield'), nameTag);
-
- var scoreTag = DIV(null, participant.score);
- scoreTag.style.position = 'absolute';
- scoreTag.style.width = '80px';
- scoreTag.style.textAlign = 'right';
- setElementPosition(scoreTag, { x: border + 870, y: border + 80 * otherPlayerIndex + 50 });
- appendChildNodes($('playfield'), scoreTag);
- $('playfield')['score-' + participant.login] = scoreTag;
+ var tray = [];
+ for (var i = 0; i < tileCount; i++) {
+ var element = IMG({src: 'images/null.png'});
+ element.style.position = 'absolute';
+ element.style.width = '34px';
+ element.style.height = '34px';
+ element.style.zIndex = '10';
+ setElementPosition(element, { x: 680 + i * 40, y: 80 * otherPlayerIndex });
+ tray[i] = element;
+ }
+ appendChildNodes($('playfield'), tray);
+
+ var nameTag = DIV(null, participant.name);
+ nameTag.style.position = 'absolute';
+ nameTag.style.width = '200px';
+ nameTag.style.textAlign = 'left';
+ setElementPosition(nameTag, { x: 680, y: 80 * otherPlayerIndex + 50 });
+ appendChildNodes($('playfield'), nameTag);
+
+ var scoreTag = DIV(null, participant.score);
+ scoreTag.style.position = 'absolute';
+ scoreTag.style.width = '80px';
+ scoreTag.style.textAlign = 'right';
+ setElementPosition(scoreTag, { x: 870, y: 80 * otherPlayerIndex + 50 });
+ appendChildNodes($('playfield'), scoreTag);
+ $('playfield')['score-' + participant.login] = scoreTag;
- otherPlayerIndex++;
+ otherPlayerIndex++;
}
function renderMoveAsText(move)
{
- var retval = move.participantLogin;
- if (move.type == 'move') {
- retval += " score: " + move.score;
- for (var i = 0; i < move.words.length; i++) {
- retval += " " + move.words[i][0] + "(" + move.words[i][1] + ")";
- }
- } else {
- retval += move.type;
- }
+ var retval = move.participantLogin;
+ if (move.type == 'move') {
+ retval += " score: " + move.score;
+ for (var i = 0; i < move.words.length; i++) {
+ retval += " " + move.words[i][0] + "(" + move.words[i][1] + ")";
+ }
+ } else {
+ retval += move.type;
+ }
- return retval;
+ return retval;
}
function displayWhosTurnItIs(name) {
- replaceChildNodes($('nextTurn'),
- "Next: " + name);
+ replaceChildNodes($('nextTurn'),
+ "Next: " + name);
}
function drawGameState (gameState) {
- try {
- for (var i = 0; i < gameState.board.length; i++) {
- var x = gameState.board[i][0];
- var y = gameState.board[i][1];
- var char = gameState.board[i][2];
- setLetter(x, y, char, gameState.board[i].length > 3);
- }
- var firstParticipant = gameState.participants[0];
- displayWhosTurnItIs(firstParticipant.name);
- for (var i = 0; i < gameState.participants.length; i++) {
- var participant = gameState.participants[i];
- makeTheirTray(participant);
- if (typeof participant.remainingTiles != 'number') {
- displayMyTray(participant.remainingTiles);
- }
- }
- // small "Kilian fix" - probably there is a nicer way to do it...
- if (gameState.moves != null) {
- for (var i = 0; i < gameState.moves.length; i++) {
- appendChildNodes($('gameLog'), DIV(null, renderMoveAsText(gameState.moves[i])));
- }
- }
- }
- catch (e) {
- alert('error ' + e + ' in drawGameState');
- }
+ try {
+ for (var i = 0; i < gameState.board.length; i++) {
+ var x = gameState.board[i][0];
+ var y = gameState.board[i][1];
+ var char = gameState.board[i][2];
+ setLetter(x, y, char, gameState.board[i].length > 3);
+ }
+ var firstParticipant = gameState.participants[0];
+ displayWhosTurnItIs(firstParticipant.name);
+ for (var i = 0; i < gameState.participants.length; i++) {
+ var participant = gameState.participants[i];
+ makeTheirTray(participant);
+ if (typeof participant.remainingTiles != 'number') {
+ displayMyTray(participant.remainingTiles);
+ }
+ }
+ for (var i = 0; gameState.moves && (i < gameState.moves.length); i++) {
+ appendChildNodes($('gameLog'), DIV(null, renderMoveAsText(gameState.moves[i])));
+ }
+ }
+ catch (e) {
+ alert('error ' + e + ' in drawGameState');
+ }
}
function displayStatus(status)
{
- replaceChildNodes('status', status);
+ replaceChildNodes('status', status);
}
+function init() {
+ makeBoard();
-// Publication
-
-function Publication() {
- this.callbacks = [];
- this.object2callback = {};
-}
-
-function extendWithPublication (obj) {
- var value;
- Publication.call(obj);
- for (p in Publication.prototype) {
- value = Publication.prototype[p];
- if (value instanceof Function)
- obj[p] = value;
- }
-}
-
-Publication.prototype = {
- subscribe : function(fnOrObject, /*optional*/ method) {
- if (!(((fnOrObject instanceof Function) && (method == undefined))
- || ((fnOrObject instanceof Object) && !(fnOrObject instanceof Function)
- && (method instanceof Function))))
- throw new Error("bad args to subscribe. use either subscribe(fn) or subscribe(obj, method)");
- if (this._isAlreadySubscribed(fnOrObject))
- return null;
- var callback = this._makeCallback(fnOrObject, method);
- this._associateObjectWithCallback(fnOrObject, callback);
- this._registerCallback(callback);
- },
- unsubscribe : function(fnOrObject) {
- var callback = this._associatedCallback(fnOrObject);
- this._unregisterCallback(callback);
- },
- unsubscribeAll : function() {
- this.callbacks = [];
- this.object2callback = {};
- },
- publish : function(/*optional*/ message) {
- this.callbacks.forEach(
- function (fn) {
- fn(message);
- });
- },
- _makeCallback : function (fnOrObject, /*optional*/ method) {
- if (fnOrObject instanceof Function) {
- return fnOrObject;
- } else {
- return function (message) { method.call(fnOrObject, message) };
- }
- },
- _associateObjectWithCallback : function (fnOrObject, callback) {
- if (!(fnOrObject instanceof Function)) {
- this.object2callback[fnOrObject] = callback;
- }
- },
- _associatedCallback : function (fnOrObject) {
- if (fnOrObject instanceof Function)
- return fnOrObject;
- else
- return this.callbacks[fnOrObject];
- },
- _registerCallback : function(callback) {
- this.callbacks.push(callback);
- },
- _unregisterCallback : function(callback) {
- this.callbacks = this.callbacks.filter(
- function (c) {
- (c === callback)
- });
- },
- _isAlreadySubscribed : function (fnOrObject) {
- return (this.object2callback[fnOrObject])
- || (this.callbacks.some(function (callback) {callback === fnOrObject}))
- }
-};
-
-// loginManager
-var loginManager = {isLoggedIn:
- function () {
- return this.loginName !== null;
- },
- loggedInAs:
- function () {
- return this.loginName;
- },
- login:
- function (name, pwd) {
- loadJSONDoc("/login?login=" + name + "&password=" + pwd).addCallbacks(
- this._requestLoginName,
- this._requestError);
- },
- logout:
- function () {
- loadJSONDoc("/logout").addCallbacks(
- this._requestLoginName,
- this._requestError);
- },
- publishLoginName:
- function () {
- this._requestLoginName();
- },
- _setLoginName:
- function (loginName) {
- var oldLoginName = loginManager.loginName;
- loginManager.loginName = loginName;
- // if (oldLoginName != loginName)
- // loginManager.publish(loginName);
- loginManager.publish(loginName);
- },
- _requestLoginName:
- function () {
- loadJSONDoc("/logged-in-as").addCallbacks(
- loginManager._setLoginName,
- loginManager._requestError);
- },
- _requestError:
- function (error) {
- alert("Request error: " + error.message)
- }
- };
-extendWithPublication(loginManager);
-
-var loginView = {loginManagerCallback:
- function (loginName) {
- if (loginName)
- loginView.changeForLoggedIn(loginName);
- else
- loginView.changeForLoggedOut();
- },
- show:
- function () {
- var container = $('playfield');
- var form = FORM({id:"loginForm", action:"post", onsubmit:"return false"},
- DIV(
- null,
- LABEL({'for':"username"}, "Username: "),
- INPUT({id:"username", name:"username", size:"20", type:"text"}),
- LABEL({'for':"password"}, "Password: "),
- INPUT({id:"password", name:"password", size:"20", type:"password"}),
- P({id:"message"}),
- BUTTON({id:"button", onlick:"return false"}, "Login")
- ));
- form.style.position = 'absolute';
- setElementPosition(form, { x: 750, y: 200 });
- setElementDimensions(form, {w:200, h:150});
- loginManager.subscribe(loginView, this.loginManagerCallback);
- appendChildNodes(container, form)
- },
- hide:
- function () {
- loginManager.subscribe(loginView, loginView.loginManagerCallback);
- removeElement($('loginForm'));
- },
- changeForLoggedIn:
- function (name) {
- loginView.hide();
- gameListView.show();
- },
- changeForLoggedOut:
- function () {
- $('message').innerHTML = "Enter your username and password to log in.";
- $('button').innerHTML = "Login";
- $('button').onclick = function () { loginManager.login($('username').value, $('password').value)};
- }};
-
-var gameListManager = {logout:
- function () {
- gameListView.hide();
- loginView.show();
- loginManager.logout();
- },
- playGame:
- function (id) {
- var d = loadJSONDoc("/play-game?gameid=" + id);
- d.addCallbacks(
- function () {
- var d = loadJSONDoc("/game");
- d.addCallbacks(drawGameState, function (error) { alert("Request error: " + error.message); });
- gameListView.hide();
- returnToGameListView.show();
- },
- requestError);
- }
- };
-
-var gameListView = {show:
- function () {
- var container = $('playfield');
- var div = DIV({id:"gameListView"});
- div.innerHTML = '<button onclick="gameListManager.logout();">Logout</button><br /><button onclick="gameListManager.playGame(108);">play game 108</button>';
- div.style.position = 'absolute';
- setElementPosition(div, { x: 750, y: 200 });
- setElementDimensions(div, {w:200, h:150});
- appendChildNodes(container, div);
- },
- hide:
- function () {
- removeElement($('gameListView'));
- }};
-
-
-// a stub really
-var returnToGameListView = {show:
- function () {
- var container = $('playfield');
- var button = BUTTON({id:'returnToGameListButton'}, "return to game list");
- button.style.position = 'absolute';
- setElementPosition(button, { x: 750, y: 200 });
- setElementDimensions(button, {w:150, h:30});
- YAHOO.util.Event.on(button, 'click', this.returnToGameList, null, this);
- // loginManager.subscribe(loginView, this.loginManagerCallback);
- appendChildNodes(container, button);
- },
- hide:
- function () {
- removeElement('returnToGameListButton');
- // FIXME for now we reload
- document.location = "scrabble.html";
- },
- returnToGameList:
- function () {
- var d = loadJSONDoc("/leave-game");
- d.addCallbacks(
- function () {
- returnToGameListView.hide();
- gameListView.show();
- },
- requestError)}
- };
-
+ // does not work for ie (document.body needed)?
+ YAHOO.util.Event.on(window, 'keypress', letterKeyPressed);
-function init() {
- makeBoard();
-
- // does not work for ie (document.body needed)?
- YAHOO.util.Event.on(window, 'keypress', letterKeyPressed);
-
- var functionKeyListener = new YAHOO.util.KeyListener(document,
- { keys: [ leftKey, upKey, rightKey, downKey, backspaceKey ] },
- { fn: functionKeyPressed, scope: this, correctScope: true });
- functionKeyListener.enable();
- var moveDisplay = DIV({ id: 'move' }, "");
- moveDisplay.style.color = 'white';
- moveDisplay.style.position = 'absolute';
- setElementPosition(moveDisplay, { x: border + 550, y: border + 665 });
- appendChildNodes(document.body, moveDisplay);
- loginView.show();
- loginManager.subscribe(function (loginName) {
- if (loginName) {
- // loginView.hide();
- }
- });
- loginManager.publishLoginName();
+ var functionKeyListener = new YAHOO.util.KeyListener(document,
+ { keys: [ leftKey, upKey, rightKey, downKey, backspaceKey ] },
+ { fn: functionKeyPressed, scope: this, correctScope: true });
+ functionKeyListener.enable();
+
+ var moveDisplay = DIV({ id: 'move' }, "");
+ moveDisplay.style.color = 'white';
+ moveDisplay.style.position = 'absolute';
+ setElementPosition(moveDisplay, { x: 550, y: 665 });
+ appendChildNodes(document.body, moveDisplay);
+ loadJSONDoc("/game/" + gameID)
+ .addCallbacks(drawGameState, function (error) { alert("Request error: " + error.message); });
}
Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp (original)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/misc.lisp Thu Jan 17 11:36:28 2008
@@ -180,7 +180,10 @@
(defun enough-url (url url-prefix)
"Returns the relative portion of URL relative to URL-PREFIX, similar
to what ENOUGH-NAMESTRING does for pathnames."
- (subseq url (mismatch url url-prefix)))
+ (let ((start (mismatch url url-prefix)))
+ (if start
+ (subseq url start)
+ "")))
(defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type)
"Creates and returns a dispatch function which will dispatch to a
Modified: branches/trunk-reorg/thirdparty/parenscript/src/js-macrology.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/parenscript/src/js-macrology.lisp (original)
+++ branches/trunk-reorg/thirdparty/parenscript/src/js-macrology.lisp Thu Jan 17 11:36:28 2008
@@ -4,7 +4,9 @@
;;; literals
(defmacro defpsliteral (name string)
- `(define-ps-special-form ,name (expecting) (list 'js-literal ,string)))
+ `(define-ps-special-form ,name (expecting)
+ (declare (ignore expecting))
+ (list 'js-literal ,string)))
(defpsliteral this "this")
(defpsliteral t "true")
@@ -15,45 +17,54 @@
(defpsliteral undefined "undefined")
(defmacro defpskeyword (name string)
- `(define-ps-special-form ,name (expecting) (list 'js-keyword ,string)))
+ `(define-ps-special-form ,name (expecting)
+ (declare (ignore expecting))
+ (list 'js-keyword ,string)))
(defpskeyword break "break")
(defpskeyword continue "continue")
(define-ps-special-form array (expecting &rest values)
+ (declare (ignore expecting))
(cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
values)))
(define-ps-special-form aref (expecting array &rest coords)
+ (declare (ignore expecting))
(list 'js-aref (compile-parenscript-form array :expecting :expression)
(mapcar (lambda (form)
(compile-parenscript-form form :expecting :expression))
coords)))
(define-ps-special-form {} (expecting &rest arrows)
+ (declare (ignore expecting))
(cons 'object-literal (loop for (key value) on arrows by #'cddr
collect (cons key (compile-parenscript-form value :expecting :expression)))))
;;; operators
(define-ps-special-form incf (expecting x &optional (delta 1))
+ (declare (ignore expecting))
(if (equal delta 1)
(list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t)
(list 'operator '+= (list (compile-parenscript-form x :expecting :expression)
(compile-parenscript-form delta :expecting :expression)))))
(define-ps-special-form decf (expecting x &optional (delta 1))
+ (declare (ignore expecting))
(if (equal delta 1)
(list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t)
(list 'operator '-= (list (compile-parenscript-form x :expecting :expression)
(compile-parenscript-form delta :expecting :expression)))))
(define-ps-special-form - (expecting first &rest rest)
+ (declare (ignore expecting))
(if (null rest)
(list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t)
(list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
(cons first rest)))))
(define-ps-special-form not (expecting x)
+ (declare (ignore expecting))
(let ((form (compile-parenscript-form x :expecting :expression))
(not-op nil))
(if (and (eql (first form) 'operator)
@@ -72,6 +83,7 @@
(list 'unary-operator "!" form :prefix t))))
(define-ps-special-form ~ (expecting x)
+ (declare (ignore expecting))
(list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t))
(defun flatten-blocks (body)
@@ -97,18 +109,21 @@
;;; function definition
(define-ps-special-form %js-lambda (expecting args &rest body)
+ (declare (ignore expecting))
(list 'js-lambda (mapcar (lambda (arg)
(compile-parenscript-form arg :expecting :symbol))
args)
(compile-parenscript-form `(progn ,@body))))
(define-ps-special-form %js-defun (expecting name args &rest body)
+ (declare (ignore expecting))
(list 'js-defun (compile-parenscript-form name :expecting :symbol)
(mapcar (lambda (val) (compile-parenscript-form val :expecting :symbol)) args)
(compile-parenscript-form `(progn ,@body))))
;;; object creation
(define-ps-special-form create (expecting &rest args)
+ (declare (ignore expecting))
(list 'js-object (loop for (name val) on args by #'cddr collecting
(let ((name-expr (compile-parenscript-form name :expecting :expression)))
(assert (or (stringp name-expr)
@@ -121,6 +136,7 @@
(list name-expr (compile-parenscript-form val :expecting :expression))))))
(define-ps-special-form %js-slot-value (expecting obj slot)
+ (declare (ignore expecting))
(if (ps::ps-macroexpand slot)
(list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
(compile-parenscript-form obj :expecting :expression)))
@@ -157,6 +173,7 @@
(compile-parenscript-form else :expecting :expression)))))
(define-ps-special-form switch (expecting test-expr &rest clauses)
+ (declare (ignore expecting))
(let ((clauses (mapcar (lambda (clause)
(let ((val (car clause))
(body (cdr clause)))
@@ -207,9 +224,11 @@
(list 'js-assign lhs rhs)))
(define-ps-special-form setf1% (expecting lhs rhs)
+ (declare (ignore expecting))
(smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))
(define-ps-special-form defvar (expecting name &rest value)
+ (declare (ignore expecting))
(append (list 'js-defvar (compile-parenscript-form name :expecting :symbol))
(when value
(assert (= (length value) 1) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
@@ -228,6 +247,7 @@
collect (compile-parenscript-form (third decl) :expecting :expression)))
(define-ps-special-form do (expecting decls termination-test &rest body)
+ (declare (ignore expecting))
(let ((vars (make-for-vars decls))
(steps (make-for-steps decls))
(test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
@@ -235,20 +255,24 @@
(list 'js-for vars steps test body)))
(define-ps-special-form doeach (expecting decl &rest body)
+ (declare (ignore expecting))
(list 'js-for-each
(compile-parenscript-form (first decl) :expecting :symbol)
(compile-parenscript-form (second decl) :expecting :expression)
(compile-parenscript-form `(progn ,@body))))
(define-ps-special-form while (expecting test &rest body)
+ (declare (ignore expecting))
(list 'js-while (compile-parenscript-form test :expecting :expression)
(compile-parenscript-form `(progn ,@body))))
(define-ps-special-form with (expecting expression &rest body)
+ (declare (ignore expecting))
(list 'js-with (compile-parenscript-form expression :expecting :expression)
(compile-parenscript-form `(progn ,@body))))
(define-ps-special-form try (expecting form &rest clauses)
+ (declare (ignore expecting))
(let ((catch (cdr (assoc :catch clauses)))
(finally (cdr (assoc :finally clauses))))
(assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
@@ -260,23 +284,28 @@
:finally (when finally (compile-parenscript-form `(progn ,@finally))))))
(define-ps-special-form regex (expecting regex)
+ (declare (ignore expecting))
(list 'js-regex (string regex)))
;;; TODO instanceof
(define-ps-special-form instanceof (expecting value type)
+ (declare (ignore expecting))
(list 'js-instanceof (compile-parenscript-form value :expecting :expression)
(compile-parenscript-form type :expecting :expression)))
;;; single operations
(mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
+ (declare (ignore expecting))
(list 'js-named-operator ',op (compile-parenscript-form value)))))
'(throw delete void typeof new))
(define-ps-special-form return (expecting &optional value)
+ (declare (ignore expecting))
(list 'js-return (compile-parenscript-form value :expecting :expression)))
;;; conditional compilation
(define-ps-special-form cc-if (expecting test &rest body)
+ (declare (ignore expecting))
(list 'cc-if test (mapcar #'compile-parenscript-form body)))
;;; standard macros
Modified: branches/trunk-reorg/thirdparty/slime/slime.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/slime.el (original)
+++ branches/trunk-reorg/thirdparty/slime/slime.el Thu Jan 17 11:36:28 2008
@@ -6287,7 +6287,9 @@
("*SLIME macroexpansion*" :mode lisp-mode :reusep t) package
(slime-macroexpansion-minor-mode)
(erase-buffer)
- (insert expansion)
+ (save-excursion
+ (insert expansion))
+ (indent-sexp)
(font-lock-fontify-buffer))))))
(defun slime-eval-macroexpand-inplace (expander)
@@ -6316,6 +6318,59 @@
(indent-sexp)
(goto-char point))))))))
+(defun slime-enclosing-macro-context-establishers ()
+ (flet ((establishes-context-p (form-spec)
+ (let ((operator-name (first form-spec)))
+ (when (stringp operator-name)
+ (let ((symbol-name (slime-cl-symbol-name operator-name)))
+ (or (equal symbol-name "macrolet") (equal symbol-name "symbol-macrolet")))))))
+ (multiple-value-bind (form-specs indices points)
+ (slime-enclosing-form-specs)
+ (loop for form-spec in form-specs
+ for index in indices
+ for point in points
+ when (establishes-context-p form-spec)
+ collect form-spec into form-specs* and
+ collect index into indices* and
+ collect point into points*
+ finally (return (values form-specs* indices* points*))))))
+
+(defun slime-collect-macro-context ()
+ (multiple-value-bind (form-specs indices points)
+ (slime-enclosing-macro-context-establishers)
+ (save-excursion
+ (let ((context))
+ (cl-mapc #'(lambda (form-spec index point)
+ (when (= index 2)
+ (destructuring-bind (operator-name) form-spec
+ (goto-char point)
+ (slime-forward-sexp)
+ (forward-char)
+ (push (cons operator-name (slime-parse-sexp-at-point 1 t)) context))))
+ form-specs indices points)
+ context))))
+
+(defun slime-rebuild-macro-context-around-string (string context)
+ (if (null context)
+ string
+ (destructuring-bind (let-operator . bindings) (first context)
+ (format "(%s %s %s)" let-operator bindings
+ (slime-rebuild-macro-context-around-string string (rest context))))))
+
+(defun slime-macroexpand-locally-1 (&optional repeatedly)
+ (interactive "P")
+ (let ((sexp (first (slime-sexp-at-point-for-macroexpansion)))
+ (macro-context (slime-collect-macro-context)))
+ (if repeatedly
+ (slime-eval-macroexpand 'swank:swank-macroexpand-locally
+ (slime-rebuild-macro-context-around-string
+ (format "(swank::macroexpand-locally %s)" sexp)
+ macro-context))
+ (slime-eval-macroexpand 'swank:swank-macroexpand-locally-1
+ (slime-rebuild-macro-context-around-string
+ (format "(swank::macroexpand-locally-1 %s)" sexp)
+ macro-context)))))
+
(defun slime-macroexpand-1 (&optional repeatedly)
"Display the macro expansion of the form at point. The form is
expanded with CL:MACROEXPAND-1 or, if a prefix argument is given, with
Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.lisp (original)
+++ branches/trunk-reorg/thirdparty/slime/swank.lisp Thu Jan 17 11:36:28 2008
@@ -78,7 +78,8 @@
"Abbreviate dotted package names to their last component if T.")
(defvar *swank-io-package*
- (let ((package (make-package :swank-io-package :use '())))
+ (let ((package (or (find-package :swank-io-package)
+ (make-package :swank-io-package :use '()))))
(import '(nil t quote) package)
package))
@@ -2401,6 +2402,22 @@
(let ((*print-readably* nil))
(disassemble (fdefinition (from-string name)))))))
+(defslimefun swank-macroexpand-locally (string)
+ (apply-macro-expander #'eval string))
+
+(defslimefun swank-macroexpand-locally-1 (string)
+ (apply-macro-expander #'eval string))
+
+(defmacro macroexpand-locally (form &environment env)
+ (multiple-value-bind (expansion expanded-p)
+ (macroexpand form env)
+ `(values ',expansion ',expanded-p)))
+
+(defmacro macroexpand-locally-1 (form &environment env)
+ (multiple-value-bind (expansion expanded-p)
+ (macroexpand-1 form env)
+ `(values ',expansion ',expanded-p)))
+
;;;; Simple completion
1
0
Author: ksprotte
Date: Thu Jan 17 11:30:34 2008
New Revision: 2335
Modified:
branches/bos/projects/bos/m2/allocation-cache.lisp
branches/bos/projects/bos/m2/allocation.lisp
branches/bos/projects/bos/m2/packages.lisp
Log:
stripped allocation-cache- prefix from some functions
Modified: branches/bos/projects/bos/m2/allocation-cache.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation-cache.lisp (original)
+++ branches/bos/projects/bos/m2/allocation-cache.lisp Thu Jan 17 11:30:34 2008
@@ -135,7 +135,7 @@
"Are regions of size N indexed?"
(<= 1 n +threshold+))
-(defun allocation-cache-find-exact-match (n &key remove)
+(defun find-exact-match (n &key remove)
"Will return a free contigous region of size N
as a list of m2 instances. If no such region exactly
matching N can be found, simply returns NIL.
@@ -147,7 +147,7 @@
(remove (index-pop n))
(t (index-lookup n))))
-(defun allocation-cache-add-area (allocation-area)
+(defun add-area (allocation-area)
(dolist (region (free-regions allocation-area)
allocation-area)
(let ((size (length region)))
@@ -155,12 +155,12 @@
(index-push size region)
(incf (ignored-size *allocation-cache*) size)))))
-(defun allocation-cache-free-regions-count ()
+(defun free-regions-count ()
(iter
(for regions in-vector (allocation-cache-index *allocation-cache*))
(summing (length regions))))
-(defun allocation-cache-free-regions-pprint ()
+(defun free-regions-pprint ()
(iter
(for regions in-vector (allocation-cache-index *allocation-cache*))
(for size upfrom 1)
@@ -173,7 +173,7 @@
(setq *allocation-cache* (make-allocation-cache))
(dolist (allocation-area (class-instances 'allocation-area))
(when (allocation-area-active-p allocation-area)
- (allocation-cache-add-area allocation-area))))
+ (add-area allocation-area))))
(defun suggest-free-region-size ()
(iter
Modified: branches/bos/projects/bos/m2/allocation.lisp
==============================================================================
--- branches/bos/projects/bos/m2/allocation.lisp (original)
+++ branches/bos/projects/bos/m2/allocation.lisp Thu Jan 17 11:30:34 2008
@@ -625,7 +625,7 @@
(assert (plusp n))
(unless (in-transaction-p)
(error "find-free-m2s called outside of the allocation transaction"))
- (or (bos.m2.allocation-cache:allocation-cache-find-exact-match n :remove t)
+ (or (bos.m2.allocation-cache:find-exact-match n :remove t)
(some (lambda (area) (allocation-area-find-free-m2s area n))
(active-allocation-areas))
(let ((area (find-inactive-allocation-area)))
Modified: branches/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp (original)
+++ branches/bos/projects/bos/m2/packages.lisp Thu Jan 17 11:30:34 2008
@@ -211,6 +211,9 @@
(:shadowing-import-from :cl-interpol #:quote-meta-chars)
(:export #:cert-daemon))
+;;; maybe there is a nicer way to do this
+;;; if you want to test this run ./build.sh at least twice !
+(intern "POINT-IN-POLYGON-P" :bos.m2)
(defpackage :bos.m2.allocation-cache
(:use :cl
1
0