January 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2414 - in branches/bos/projects/bos: m2 web
by ksprotte＠common-lisp.net 29 Jan '08

29 Jan '08

Author: ksprotte Date: Tue Jan 29 06:43:20 2008 New Revision: 2414 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/web/kml-handlers.lisp Log: kml-handler now uses the new function CONTRACT-NEIGHBOURS and exports and entire region (a first version...) Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Tue Jan 29 06:43:20 2008 @@ -44,10 +44,16 @@ (setf (first ,point) x (second ,point) y) (when ,(if test - `(funcall ,test point) + `(funcall ,test ,point) t) ,@body))))) +(defun rect-center (left top width height &key roundp) + (let ((x (+ left (/ width 2))) + (y (+ top (/ height 2)))) + (if roundp + (list (round x) (round y)) + (list x y)))) ;; maybe change this function to take a ;; point as an argument? Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Tue Jan 29 06:43:20 2008 @@ -350,6 +350,21 @@ (setf max-y (max (m2-y m2) (or max-y (m2-y m2))))) (list min-x min-y (1+ (- max-x min-x)) (1+ (- max-y min-y))))) +(defun contract-neighbours (contract &optional (radius 100)) + (destructuring-bind (left top width height) + (contract-bounding-box contract) + (let ((center (rect-center left top width height :roundp t)) + (diameter (* 2 radius)) + (contracts (make-hash-table :test #'eq))) + (with-points (center) + (dorect (point ((- center-x radius) (- center-y radius) diameter diameter) + :test (lambda (point) (point-in-circle-p point center radius))) + (with-points (point) + (awhen (get-m2 point-x point-y) + (when (m2-contract it) + (setf (gethash (m2-contract it) contracts) t)))))) + (hash-keys contracts)))) + (defun tx-make-contract (sponsor m2-count &key date paidp expires) (warn "Old tx-make-contract transaction used, contract dates may be wrong") (tx-do-make-contract sponsor m2-count :date date :paidp paidp :expires expires)) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Tue Jan 29 06:43:20 2008 @@ -2,7 +2,10 @@ (defpackage :geometry (:use :cl :iterate :arnesi) - (:export #:distance + (:export #:with-points + #:distance + #:dorect + #:rect-center #:point-in-polygon-p #:point-in-circle-p #:find-boundary-point @@ -127,6 +130,7 @@ #:contract-date #:contract-m2s #:contract-bounding-box + #:contract-neighbours #:contract-color #:contract-cert-issued #:contract-set-paidp Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Tue Jan 29 06:43:20 2008 @@ -1,15 +1,5 @@ (in-package :bos.web) -(defun contract-utm-bounding-box (contract) - "Returns LEFT, TOP, RIGHT, BOTTOM." - (let (min-x min-y max-x max-y) - (dolist (m2 (contract-m2s contract)) - (setf min-x (min (m2-utm-x m2) (or min-x (m2-utm-x m2)))) - (setf min-y (min (m2-utm-y m2) (or min-y (m2-utm-y m2)))) - (setf max-x (max (m2-utm-x m2) (or max-x (m2-utm-x m2)))) - (setf max-y (max (m2-utm-y m2) (or max-y (m2-utm-y m2))))) - (list min-x max-y max-x min-y))) - (defun kml-format-points (points) (format nil "~:{~F,~F,0 ~}" points)) @@ -20,28 +10,31 @@ ()) (defmethod handle-object ((handler contract-kml-handler) (contract contract) req) - (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") + (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") ;; when name is xmlns, the attribute does not show up - why (?) ;; (attribute "xmlns" "http://earth.google.com/kml/2.2") - (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract)))) - (with-element "Document" - (with-element "Placemark" - (with-element "name" (format nil "contract~a" (store-object-id contract))) - (with-element "description" "a description") - (with-element "Style" - (attribute "id" "#region") - (with-element "LineStyle" - (with-element "color" (text "ffff3500"))) - (with-element "PolyStyle" - (with-element "color" (text (kml-format-color (contract-color contract) 175))))) - (with-element "Polygon" - (with-element "styleUrl" "#region") - (with-element "tessellate" (text "1")) - (with-element "outerBoundaryIs" - (with-element "LinearRing" - (with-element "coordinates" - (text (kml-format-points polygon))))))))))) + (with-element "Document" + (dolist (contract (contract-neighbours contract)) + (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract))) + (name (user-full-name (contract-sponsor contract)))) + (with-element "Placemark" + (with-element "name" (text (format nil "~A ~Dm2" + (if name name "anonymous") + (length (contract-m2s contract))))) + (with-element "description" (text "a description")) + (with-element "Style" + (attribute "id" "#region") + (with-element "LineStyle" + (with-element "color" (text "ffff3500"))) + (with-element "PolyStyle" + (with-element "color" (text (kml-format-color (contract-color contract) 175))))) + (with-element "Polygon" + (with-element "styleUrl" "#region") + (with-element "tessellate" (text "1")) + (with-element "outerBoundaryIs" + (with-element "LinearRing" + (with-element "coordinates" + (text (kml-format-points polygon)))))))))))) (defmethod handle-object ((handle-object contract-kml-handler) (object null) req) (error "Contract not found.")) -

1 0

[bknr-cvs] r2413 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 29 Jan '08

29 Jan '08

Author: ksprotte Date: Tue Jan 29 05:06:55 2008 New Revision: 2413 Modified: branches/bos/projects/bos/m2/geometry.lisp Log: added macro DORECT in geometry.lisp Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Tue Jan 29 05:06:55 2008 @@ -2,6 +2,7 @@ ;; a point in this package is represented ;; as a list (x y) + (defmacro with-point (point &body body) (let* ((*package* (symbol-package point)) (x (intern (format nil "~A-X" (symbol-name point)))) @@ -21,6 +22,33 @@ (sqrt (+ (expt (- point-a-x point-b-x) 2) (expt (- point-a-y point-b-y) 2))))) +(defmacro dorect ((point (left top width height) &key test row-change) &body body) + "Iterate with POINT over all points in rect row per row. The list +containing x and y is intended for only extracting those +and not to be stored away (it will be modified). + +BODY is only executed, if TEST of the current point is true. + +For convenience, a null arg function ROW-CHANGE can be given +that will be called between the rows." + (check-type point symbol) + (rebinding (left top) + `(iter + (with ,point = (list nil nil)) + (for y from ,top to (1- (+ ,top ,height))) + ,(when row-change + `(unless (first-time-p) + (funcall ,row-change))) + (iter + (for x from ,left to (1- (+ ,left ,width))) + (setf (first ,point) x + (second ,point) y) + (when ,(if test + `(funcall ,test point) + t) + ,@body))))) + + ;; maybe change this function to take a ;; point as an argument? (defun point-in-polygon-p (x y polygon) @@ -42,6 +70,14 @@ (defun point-in-circle-p (point center radius) (<= (distance point center) radius)) +;;; for fun... +(defun point-in-circle-p-test () + (let ((center (list 4 4))) + (dorect (p (0 0 10 10) :row-change #'terpri) + (if (point-in-circle-p p center 3) + (princ "x") + (princ "."))))) + ;;; directions ;; A direction can be represented either

1 0

[bknr-cvs] r2412 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 29 Jan '08

29 Jan '08

Author: ksprotte Date: Tue Jan 29 04:17:50 2008 New Revision: 2412 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/packages.lisp Log: added DISTANCE and POINT-IN-CIRCLE-P to geometry.lisp Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Tue Jan 29 04:17:50 2008 @@ -1,8 +1,25 @@ - (in-package :geometry) ;; a point in this package is represented ;; as a list (x y) +(defmacro with-point (point &body body) + (let* ((*package* (symbol-package point)) + (x (intern (format nil "~A-X" (symbol-name point)))) + (y (intern (format nil "~A-Y" (symbol-name point))))) + `(destructuring-bind (,x ,y) ,point + ,@body))) + +(defmacro with-points ((&rest points) &body body) + (if (null points) + `(progn ,@body) + `(with-point ,(car points) + (with-points (,@(cdr points)) + ,@body)))) + +(defun distance (point-a point-b) + (with-points (point-a point-b) + (sqrt (+ (expt (- point-a-x point-b-x) 2) + (expt (- point-a-y point-b-y) 2))))) ;; maybe change this function to take a ;; point as an argument? @@ -22,6 +39,9 @@ pjy piy)) result)) +(defun point-in-circle-p (point center radius) + (<= (distance point center) radius)) + ;;; directions ;; A direction can be represented either Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Tue Jan 29 04:17:50 2008 @@ -2,7 +2,9 @@ (defpackage :geometry (:use :cl :iterate :arnesi) - (:export #:point-in-polygon-p + (:export #:distance + #:point-in-polygon-p + #:point-in-circle-p #:find-boundary-point #:region-to-polygon))

1 0

[bknr-cvs] r2411 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 28 Jan '08

28 Jan '08

Author: ksprotte Date: Mon Jan 28 11:09:33 2008 New Revision: 2411 Modified: branches/bos/projects/bos/web/news-handlers.lisp Log: a test commit for #7 Modified: branches/bos/projects/bos/web/news-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/news-handlers.lisp (original) +++ branches/bos/projects/bos/web/news-handlers.lisp Mon Jan 28 11:09:33 2008 @@ -11,22 +11,23 @@ (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) (let ((language (session-variable :language))) - (with-bos-cms-page (req :title "Choose news item to edit") + (with-bos-cms-page (req :title "Edit news items") (content-language-chooser req) - (if (all-news-items) - (html - (:h2 "Choose existing news item") - (:ul - (dolist (news-item (all-news-items)) - (let ((id (store-object-id news-item))) - (html (:li (cmslink #?"edit-news/$(id)" - (:princ-safe (format-date-time (news-item-time news-item))) - " - " - (:princ-safe (or (news-item-title news-item language) "[no title in this language]"))))))))) - (html - (:h2 "No news items created yet"))) + (:h2 "Create new item") ((:form :method "post") - (submit-button "new" "new"))))) + (submit-button "new" "new")) + (if (all-news-items) + (html + (:h2 "Choose existing news item") + (:ul + (dolist (news-item (all-news-items)) + (let ((id (store-object-id news-item))) + (html (:li (cmslink #?"edit-news/$(id)" + (:princ-safe (format-date-time (news-item-time news-item))) + " - " + (:princ-safe (or (news-item-title news-item language) "[no title in this language]"))))))))) + (html + (:h2 "No news items created yet")))))) (defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)) req) (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))) req))

1 0

[bknr-cvs] r2410 - in branches/trunk-reorg/thirdparty/slime: . CVS contrib contrib/CVS doc doc/CVS
by hhubner＠common-lisp.net 28 Jan '08

28 Jan '08

Author: hhubner Date: Mon Jan 28 06:47:40 2008 New Revision: 2410 Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries branches/trunk-reorg/thirdparty/slime/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries branches/trunk-reorg/thirdparty/slime/doc/slime.texi branches/trunk-reorg/thirdparty/slime/slime.el branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp branches/trunk-reorg/thirdparty/slime/swank-scl.lisp branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp branches/trunk-reorg/thirdparty/slime/swank.lisp Log: update from recent CVS slime Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/CVS/Entries Mon Jan 28 06:47:40 2008 @@ -1,35 +1,35 @@ -/.cvsignore/1.5/Thu Oct 11 14:10:25 2007// -/HACKING/1.8/Thu Oct 11 14:10:25 2007// -/PROBLEMS/1.8/Thu Oct 11 14:10:25 2007// -/README/1.14/Thu Oct 11 14:10:25 2007// -/hyperspec.el/1.11/Thu Oct 11 14:10:25 2007// -/metering.lisp/1.4/Thu Oct 11 14:10:25 2007// -/mkdist.sh/1.7/Thu Oct 11 14:10:25 2007// -/nregex.lisp/1.4/Thu Oct 11 14:10:25 2007// -/sbcl-pprint-patch.lisp/1.1/Thu Oct 11 14:10:25 2007// -/slime-autoloads.el/1.3/Thu Oct 11 14:10:25 2007// -/swank-abcl.lisp/1.44/Wed Nov 14 21:30:35 2007// -/swank-allegro.lisp/1.98/Thu Oct 11 14:10:25 2007// -/swank-backend.lisp/1.126/Thu Oct 11 14:10:25 2007// -/swank-clisp.lisp/1.64/Thu Oct 11 14:10:25 2007// -/swank-corman.lisp/1.11/Thu Oct 11 14:10:25 2007// -/swank-ecl.lisp/1.8/Thu Oct 11 14:10:25 2007// -/swank-gray.lisp/1.10/Thu Oct 11 14:10:25 2007// -/swank-openmcl.lisp/1.120/Wed Nov 14 21:30:35 2007// -/swank-sbcl.lisp/1.185/Thu Oct 11 14:10:25 2007// -/swank-scl.lisp/1.13/Thu Oct 11 14:10:25 2007// -/swank-source-file-cache.lisp/1.8/Thu Oct 11 14:10:25 2007// -/swank-source-path-parser.lisp/1.17/Thu Oct 11 14:10:25 2007// -/swank.asd/1.5/Thu Oct 11 14:10:25 2007// -/test-all.sh/1.2/Thu Oct 11 14:10:25 2007// -/test.sh/1.9/Thu Oct 11 14:10:25 2007// -/xref.lisp/1.2/Thu Oct 11 14:10:25 2007// D/contrib//// D/doc//// -/ChangeLog/1.1254/Sun Dec 2 04:22:09 2007// -/NEWS/1.9/Sun Dec 2 04:22:09 2007// -/slime.el/1.882/Sun Dec 2 04:22:09 2007// -/swank-cmucl.lisp/1.175/Sun Dec 2 04:22:09 2007// -/swank-lispworks.lisp/1.93/Sun Dec 2 04:22:09 2007// -/swank-loader.lisp/1.75/Sun Dec 2 04:22:09 2007// -/swank.lisp/1.521/Sun Dec 2 04:22:09 2007// +/.cvsignore/1.5/Sun Apr 8 19:23:57 2007// +/ChangeLog/1.1274/Sun Jan 27 22:03:20 2008// +/HACKING/1.8/Sun Jan 27 22:03:20 2008// +/NEWS/1.9/Sun Jan 27 22:03:20 2008// +/PROBLEMS/1.8/Sun Jan 27 22:03:20 2008// +/README/1.14/Sun Jan 27 22:03:20 2008// +/hyperspec.el/1.11/Sun Jan 27 22:03:20 2008// +/metering.lisp/1.4/Sun Jan 27 22:03:20 2008// +/mkdist.sh/1.7/Sun Jan 27 22:03:20 2008// +/nregex.lisp/1.4/Sun Jan 27 22:03:20 2008// +/sbcl-pprint-patch.lisp/1.1/Sun Jan 27 22:03:20 2008// +/slime-autoloads.el/1.3/Sun Jan 27 22:03:20 2008// +/slime.el/1.896/Sun Jan 27 22:03:20 2008// +/swank-abcl.lisp/1.44/Sun Jan 27 22:03:20 2008// +/swank-allegro.lisp/1.98/Sun Jan 27 22:03:20 2008// +/swank-backend.lisp/1.126/Sun Jan 27 22:03:21 2008// +/swank-clisp.lisp/1.64/Sun Jan 27 22:03:21 2008// +/swank-cmucl.lisp/1.175/Sun Jan 27 22:03:21 2008// +/swank-corman.lisp/1.11/Sun Jan 27 22:03:21 2008// +/swank-ecl.lisp/1.11/Sun Jan 27 22:03:21 2008// +/swank-gray.lisp/1.10/Sun Jan 27 22:03:21 2008// +/swank-lispworks.lisp/1.93/Sun Jan 27 22:03:21 2008// +/swank-loader.lisp/1.75/Sun Jan 27 22:03:21 2008// +/swank-openmcl.lisp/1.120/Sun Jan 27 22:03:21 2008// +/swank-sbcl.lisp/1.187/Sun Jan 27 22:03:21 2008// +/swank-scl.lisp/1.14/Sun Jan 27 22:03:21 2008// +/swank-source-file-cache.lisp/1.8/Sun Jan 27 22:03:21 2008// +/swank-source-path-parser.lisp/1.18/Sun Jan 27 22:03:21 2008// +/swank.asd/1.5/Sun Jan 27 22:03:21 2008// +/swank.lisp/1.523/Sun Jan 27 22:03:21 2008// +/test-all.sh/1.2/Sun Jan 27 22:03:21 2008// +/test.sh/1.9/Sun Jan 27 22:03:21 2008// +/xref.lisp/1.2/Sun Jan 27 22:03:21 2008// Modified: branches/trunk-reorg/thirdparty/slime/ChangeLog ============================================================================== --- branches/trunk-reorg/thirdparty/slime/ChangeLog (original) +++ branches/trunk-reorg/thirdparty/slime/ChangeLog Mon Jan 28 06:47:40 2008 @@ -1,3 +1,156 @@ +2008-01-27 Helmut Eller <heller(a)common-lisp.net> + + Make it easier to start a non-default Lisp from ELisp code. + + * slime.el (slime): If the argument is a symbol start the + corresponding entry in slime-lisp-implementations. + Typical use is something like: + (defun cmucl () (interactive) (slime 'cmucl)) + +2008-01-22 Lu�s Oliveira <loliveira(a)common-lisp.net> + + * swank-source-path-parser.lisp (make-source-recording-readtable): + don't suppress the #. reader macro. + (read-and-record-source-map): don't bind *read-eval* to nil. + (suppress-sharp-dot): unused, delete it. + + * slime.el (test compile-defun): test with #+#.'(:and). + +2008-01-21 Helmut Eller <heller(a)common-lisp.net> + + * slime.el (sldb-mode): Don't throw to toplevel in the + kill-buffer-hook, since the buffer can be killed for other reasons + too. + (test break): Test BREAK and CONTINUE in a loop. + (slime-wait-condition): Display the current time. + +2008-01-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + New hooks that allow the slime-presentations contrib to hook + into the debugger and inspector. + + * slime.el (sldb-insert-frame-variable-value-function): New + variable. + (sldb-insert-frame-variable-value): New function, default value + for sldb-insert-frame-variable-value-function. + (sldb-insert-locals): Use it here. + + * slime.el (slime-inspector-insert-ispec-function): New variable. + (slime-open-inspector): Use it here. + +2008-01-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + * doc/slime.texi (Presentations): Improve documentation of + presentations. + +2008-01-19 Geo Carncross <geocar(a)gmail.com> + + * swank-ecl.lisp (inspect-for-emacs): Make ECL inspection better; + should be able to handle all builtin types and CLOS objects now. + +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. @@ -7,7 +160,7 @@ (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. Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries Mon Jan 28 06:47:40 2008 @@ -1,30 +1,33 @@ -/README/1.3/Thu Oct 11 14:10:25 2007// -/bridge.el/1.1/Thu Oct 11 14:10:25 2007// -/inferior-slime.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-asdf.el/1.3/Thu Oct 11 14:10:25 2007// -/slime-autodoc.el/1.5/Thu Oct 11 14:10:25 2007// -/slime-banner.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007// -/slime-editing-commands.el/1.5/Thu Oct 11 14:10:25 2007// -/slime-fancy-inspector.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-fancy.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007// -/slime-parse.el/1.7/Thu Oct 11 14:10:25 2007// -/slime-presentation-streams.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-presentations.el/1.8/Thu Oct 11 14:10:25 2007// -/slime-references.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-scratch.el/1.4/Thu Oct 11 14:10:25 2007// -/slime-tramp.el/1.2/Thu Oct 11 14:10:25 2007// -/slime-typeout-frame.el/1.5/Thu Oct 11 14:10:25 2007// -/slime-xref-browser.el/1.1/Thu Oct 11 14:10:25 2007// -/swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007// -/swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007// -/swank-fuzzy.lisp/1.6/Thu Oct 11 14:10:25 2007// -/swank-listener-hooks.lisp/1.1/Thu Oct 11 14:10:25 2007// -/swank-presentation-streams.lisp/1.4/Thu Oct 11 14:10:25 2007// -/swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007// -/swank-fancy-inspector.lisp/1.5/Wed Nov 21 20:47:43 2007// -/ChangeLog/1.68/Sun Dec 2 04:22:09 2007// -/slime-fuzzy.el/1.5/Sun Dec 2 04:22:09 2007// -/swank-arglists.lisp/1.15/Sun Dec 2 04:22:10 2007// +/ChangeLog/1.82/Sun Jan 27 22:03:21 2008// +/README/1.3/Sun Jan 27 22:03:21 2008// +/bridge.el/1.1/Sun Jan 27 22:03:22 2008// +/inferior-slime.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-asdf.el/1.3/Sun Jan 27 22:03:22 2008// +/slime-autodoc.el/1.7/Sun Jan 27 22:03:22 2008// +/slime-banner.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-c-p-c.el/1.8/Sun Jan 27 22:03:22 2008// +/slime-editing-commands.el/1.6/Sun Jan 27 22:03:22 2008// +/slime-fancy-inspector.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-fancy.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-fuzzy.el/1.6/Sun Jan 27 22:03:22 2008// +/slime-highlight-edits.el/1.3/Sun Jan 27 22:03:22 2008// +/slime-parse.el/1.10/Sun Jan 27 22:03:22 2008// +/slime-presentation-streams.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-presentations.el/1.12/Sun Jan 27 22:03:22 2008// +/slime-references.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-scheme.el/1.1/Wed Jan 9 18:30:26 2008// +/slime-scratch.el/1.4/Sun Jan 27 22:03:22 2008// +/slime-tramp.el/1.2/Sun Jan 27 22:03:22 2008// +/slime-typeout-frame.el/1.6/Sun Jan 27 22:03:22 2008// +/slime-xref-browser.el/1.1/Sun Jan 27 22:03:22 2008// +/swank-arglists.lisp/1.18/Sun Jan 27 22:03:22 2008// +/swank-asdf.lisp/1.1/Sun Jan 27 22:03:22 2008// +/swank-c-p-c.lisp/1.2/Sun Jan 27 22:03:22 2008// +/swank-fancy-inspector.lisp/1.5/Sun Jan 27 22:03:22 2008// +/swank-fuzzy.lisp/1.7/Sun Jan 27 22:03:22 2008// +/swank-goo.goo/1.1/Sat Jan 19 14:08:27 2008// +/swank-kawa.scm/1.1/Sat Jan 19 14:08:27 2008// +/swank-listener-hooks.lisp/1.1/Sun Jan 27 22:03:22 2008// +/swank-presentation-streams.lisp/1.4/Sun Jan 27 22:03:22 2008// +/swank-presentations.lisp/1.4/Sun Jan 27 22:03:22 2008// D Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog Mon Jan 28 06:47:40 2008 @@ -1,3 +1,151 @@ +2008-01-27 Helmut Eller <heller(a)common-lisp.net> + + Make autodoc use the correct width of the typeout-window. + + * slime-autodoc.el (slime-autodoc-dimensions-function): New + variable. + (slime-autodoc-message-dimensions): Use it. + + * slime-typeout-frame.el (slime-typeout-autodoc-dimensions): New + function. + (slime-typeout-frame-init): Use it. + +2008-01-27 Helmut Eller <heller(a)common-lisp.net> + + Use slime-require instead of a connected-hook. + + * slime-autodoc.el (slime-autodoc-on-connect): Deleted. + +2008-01-20 Matthias Koeppe <mkoeppe(a)mail.math.uni-magdeburg.de> + + Hook presentations into debugger and inspector, restoring + features that were removed on 2007-08-27. + + * slime-presentations.el (slime-presentation-add-easy-menu): + Install presentation menu also in the debugger and inspector. + (slime-presentation-inspector-insert-ispec): New. + (slime-presentation-sldb-insert-frame-variable-value): New. + (slime-presentations-init): Install these functions as + slime-inspector-insert-ispec-function and + sldb-insert-frame-variable-value-function. + +2008-01-19 Helmut Eller <heller(a)common-lisp.net> + + * swank-goo.goo: New file. + * swank-kawa.scm: New file. + +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 Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-autodoc.el Mon Jan 28 06:47:40 2008 @@ -116,10 +116,14 @@ (setq slime-autodoc-last-message doc) (message "%s" doc)) +(defvar slime-autodoc-dimensions-function nil) + (defun slime-autodoc-message-dimensions () "Return the available width and height for pretty printing autodoc messages." (cond + (slime-autodoc-dimensions-function + (funcall slime-autodoc-dimensions-function)) (slime-autodoc-use-multiline-p ;; Use the full width of the minibuffer; ;; minibuffer will grow vertically if necessary @@ -253,21 +257,18 @@ (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))) +(slime-require :swank-arglists) + (provide 'slime-autodoc) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-editing-commands.el Mon Jan 28 06:47:40 2008 @@ -69,7 +69,7 @@ (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)) + (ignore-errors (backward-up-list 1) t)) (incf sexp-level)))) (when (> sexp-level 0) ;; insert correct number of right parens @@ -79,7 +79,7 @@ (setq point (point)) (skip-chars-forward " \t\n)") (skip-chars-backward " \t\n") - (let* ((deleted-region (delete-and-extract-region point (point))) + (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 Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fuzzy.el Mon Jan 28 06:47:40 2008 @@ -30,8 +30,8 @@ :type 'integer) (defcustom slime-fuzzy-completion-time-limit-in-msec 1500 - "Limit the time spent (given in msec) in swank while gathering comletitions. -\(NOTE: currently it's rounded up the nearest second)" + "Limit the time spent (given in msec) in swank while gathering +comletitions." :group 'slime-mode :type 'integer) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-parse.el Mon Jan 28 06:47:40 2008 @@ -16,14 +16,15 @@ (slime-enclosing-form-specs) (if (null operators) "" - (let ((op (first 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-ensure-list - (save-excursion (goto-char (first points)) - (slime-parse-sexp-at-point - (1+ (first arg-indices))))))))))) + (t + (slime-make-form-spec-from-string + (concat (slime-incomplete-sexp-at-point) ")")))))))) ;; XXX: unused function (defun slime-cl-symbol-external-ref-p (symbol) @@ -228,9 +229,11 @@ => (\"foo\" (\"bar\" \"1\" (\"baz\" \":quux\")) \"'toto\") " - (cond ((slime-length= string 0) "") - ((equal string "()") '()) - (t + (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 @@ -246,17 +249,18 @@ (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)))))))))) + (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) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-presentations.el Mon Jan 28 06:47:40 2008 @@ -275,6 +275,13 @@ (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 @@ -345,40 +352,58 @@ (slime-presentation-around-click event) (if (with-current-buffer buffer (eq major-mode 'slime-repl-mode)) - (slime-copy-presentation-at-mouse event) + (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) - (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)))) + (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 (event) +(defun slime-copy-presentation-at-mouse-to-repl (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)))) - (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))))))) + (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") @@ -395,29 +420,94 @@ (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) - (let ((presentation-text - (with-current-buffer buffer - (buffer-substring start end)))) - (kill-new presentation-text)))) + (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-eval-describe - `(swank::describe-to-string - (swank::lookup-presented-object ',(slime-presentation-id presentation)))))) + (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-eval-describe - `(swank::swank-pprint - (cl:list - (swank::lookup-presented-object ',(slime-presentation-id presentation))))))) + (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)) @@ -451,7 +541,7 @@ ("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)) + ("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)))) @@ -541,6 +631,64 @@ (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-define menubar-slime-presentation slime-inspector-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) + (easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map)) ;;; hook functions (hard to isolate stuff) @@ -622,7 +770,38 @@ bridge-handlers))) (defun slime-clear-presentations () - (slime-eval-async `(swank:clear-repl-results))) + "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)))) + +(defun slime-presentation-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) + (slime-insert-presentation string `(:inspected-part ,id) t))) + ((:action string id) + (slime-insert-propertized (list 'slime-action-number id + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + string))))) + +(defun slime-presentation-sldb-insert-frame-variable-value (value frame index) + (slime-insert-presentation + (in-sldb-face local-value value) + `(:frame-var ,slime-current-thread ,(car frame) ,i) t)) ;;; Initialization @@ -639,7 +818,12 @@ (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)) + (add-hook 'slime-connected-hook 'slime-install-presentations) + (setq slime-inspector-insert-ispec-function 'slime-presentation-inspector-insert-ispec) + (setq sldb-insert-frame-variable-value-function + 'slime-presentation-sldb-insert-frame-variable-value) + (slime-presentation-init-keymaps) + (slime-presentation-add-easy-menu)) (defun slime-install-presentations () (slime-eval-async '(swank:swank-require :swank-presentations))) Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/slime-typeout-frame.el Mon Jan 28 06:47:40 2008 @@ -64,6 +64,12 @@ (setq slime-autodoc-last-message "") (slime-typeout-message-aux "%s" doc)) +(defun slime-typeout-autodoc-dimensions () + (cond ((slime-typeout-active-p) + (list (window-width slime-typeout-window) nil)) + (t + (list 75 nil)))) + ;;; Initialization @@ -74,7 +80,8 @@ (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)) + (slime-autodoc-message-function slime-typeout-autodoc-message) + (slime-autodoc-dimensions-function slime-typeout-autodoc-dimensions)) do (slime-typeout-frame-init-var var value))) (defun slime-typeout-frame-init-var (var value) @@ -86,6 +93,7 @@ (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))))) + (t (set var value)))) + (setq slime-typeout-frame-unbind-stack nil)) (provide 'slime-typeout-frame) Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp Mon Jan 28 06:47:40 2008 @@ -72,7 +72,14 @@ (let ((op-rawspec (nth (1+ position) raw-specs))) (first (parse-form-spec op-rawspec #'read-conversatively-for-autodoc)))) -(defvar *arglist-dummy* (cons :dummy nil)) +;; 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. @@ -83,8 +90,8 @@ automatic arglist display stuff from Slime, interning freshly symbols is a big no-no. -In such a case (that no symbol could be found), the object -*ARGLIST-DUMMY* is returned instead, which works as a placeholder +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) #\'))) @@ -92,7 +99,7 @@ (parse-symbol (if quoted? (subseq string 1) string)) (if found? (if quoted? `(quote ,symbol) symbol) - *arglist-dummy*)))) + (make-arglist-dummy :string-representation string))))) (defun parse-form-spec (raw-spec &optional reader) @@ -215,7 +222,7 @@ (push sexp result) (when newly-interned? (push sexp newly-interned-symbols)))) - (cons + (list (multiple-value-bind (read-spec interned-symbols) (read-form-spec element reader) (push read-spec result) @@ -232,7 +239,8 @@ the flag if a symbol had to be interned." (multiple-value-bind (sexp pos interned?) (read-softly-from-string string) - (declare (ignore pos)) + ;; To make sure that we haven't got any junk from Emacs. + (assert (= pos (length string))) (values sexp interned?))) Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fuzzy.lisp Mon Jan 28 06:47:40 2008 @@ -220,15 +220,20 @@ ;; 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 filter removes all those symbols which are also present - ;; in one of the other packages, specifically if such a package - ;; represents the home package of the symbol, because that one - ;; is deemed to be the best match. + ;; 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))) @@ -261,9 +266,9 @@ (* 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 - ;; only if no matching in FUZZY-PACKAGE-MATCHINGS represents the - ;; home-package of the. + ;; 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)))) @@ -285,7 +290,7 @@ (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! Modified: branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries ============================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries (original) +++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries Mon Jan 28 06:47:40 2008 @@ -1,9 +1,9 @@ -/.cvsignore/1.1/Thu Oct 11 14:10:24 2007// -/Makefile/1.12/Thu Oct 11 14:10:24 2007// -/slime-refcard.pdf/1.1/Thu Oct 11 14:10:24 2007// -/slime-refcard.tex/1.1/Thu Oct 11 14:10:24 2007// -/slime-small.eps/1.1/Thu Oct 11 14:10:24 2007// -/slime-small.pdf/1.1/Thu Oct 11 14:10:24 2007// -/texinfo-tabulate.awk/1.2/Thu Oct 11 14:10:24 2007// -/slime.texi/1.61/Sun Dec 2 04:22:10 2007// +/.cvsignore/1.1/Mon Jul 24 14:13:23 2006// +/Makefile/1.12/Sun Jan 27 22:03:22 2008// +/slime-refcard.pdf/1.1/Sun Jan 27 22:03:22 2008// +/slime-refcard.tex/1.1/Sun Jan 27 22:03:22 2008// +/slime-small.eps/1.1/Sun Jan 27 22:03:22 2008// +/slime-small.pdf/1.1/Sun Jan 27 22:03:22 2008// +/slime.texi/1.64/Sun Jan 27 22:03:22 2008// +/texinfo-tabulate.awk/1.2/Sun Jan 27 22:03:22 2008// D Modified: branches/trunk-reorg/thirdparty/slime/doc/slime.texi ============================================================================== --- branches/trunk-reorg/thirdparty/slime/doc/slime.texi (original) +++ branches/trunk-reorg/thirdparty/slime/doc/slime.texi Mon Jan 28 06:47:40 2008 @@ -12,7 +12,7 @@ @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 UPDATED @code{$Date: 2008/01/20 16:57:49 $} @set TITLE SLIME User Manual @settitle @value{TITLE}, version @value{EDITION} @@ -1347,7 +1347,7 @@ @c @kbditem{C-c M-g, slime-quit} @c Quit slime. -@kbditem{C-c C-t, slime-repl-clear-buffer} +@kbditem{C-c M-o, slime-repl-clear-buffer} Clear the entire buffer, leaving only a prompt. @kbditem{C-c C-o, slime-repl-clear-output} @@ -2188,7 +2188,7 @@ @node Contributed Packages @chapter Contributed Packages -In version 3.0 we moved some functionility to separate packages. This +In version 3.0 we moved some functionality to separate packages. This chapter tells you how to load contrib modules and describes what the particular packages do. @@ -2237,7 +2237,7 @@ available. @node Compound Completion -@section Compund Completion +@section Compound Completion @anchor{slime-complete-symbol*} The package @code{slime-c-p-c} provides a different symbol completion @@ -2270,14 +2270,40 @@ @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. +In addition, @code{slime-c-p-c} provides completion for character names +(mostly useful for Unicode-aware implementations): + +@example +CL-USER> #\Sp<TAB> +@end example + +Here SLIME will usually complete the character to @code{#\Space}, but +in a Unicode-aware implementation, this might provide the following completions: +@example +Space Space +Sparkle Spherical_Angle +Spherical_Angle_Opening_Left Spherical_Angle_Opening_Up +@end example + +The package @code{slime-c-p-c} also provides context-sensitive completion for keywords. +Example: + +@example +CL-USER> (find 1 '(1 2 3) :s<TAB> +@end example + +Here SLIME will complete @code{:start}, rather than suggesting all +ever-interned keywords starting with @code{:s}. + + @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: +functions and for handling @code{make-instance}, +@code{defmethod}, and many other functions. Examples: @example (subseq "abc" <C-c C-s> @@ -2472,26 +2498,138 @@ 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. +For instance, pathnames have a dired operation. + +More importantly, it is possible to cut and paste presentations (i.e., +Lisp objects, not just their printed presentation), using all standard +Emacs commands. This way it is possible to cut and paste the results of +previous computations in the REPL. This is of particular importance for +unreadable objects. The package @code{slime-presentations} installs presentations in the -REPL, i.e. the results of evaluation commands become presentations. +REPL, i.e. the results of evaluation commands become presentations. In +this way, presentations generalize the use of the standard Common Lisp +REPL history variables @code{*}, @code{**}, @code{***}. Example: + +@example +CL-USER> (find-class 'standard-class) +@emph{#<STANDARD-CLASS STANDARD-CLASS>} +CL-USER> +@end example + +Presentations appear in red color in the buffer. +(In this manual, we indicate the presentations @emph{like this}.) +Using standard Emacs +commands, the presentation can be copied to a new input in the REPL: + +@example +CL-USER> (eql '@emph{#<STANDARD-CLASS STANDARD-CLASS>} '@emph{#<STANDARD-CLASS STANDARD-CLASS>}) +@emph{T} +@end example + +When you copy an incomplete presentation or edit the text within a +presentation, the presentation changes to plain text, losing the +association with a Lisp object. In the buffer, this is indicated by +changing the color of the text from red to black. This can be undone. + +Presentations are also available in the inspector (all inspectable parts +are presentations) and the debugger (all local variables are +presentations). This makes it possible to evaluate expressions in the +REPL using objects that appear in local variables of some active +debugger frame; this can be more convenient than using @code{M-x +sldb-eval-in-frame}. @strong{Warning:} The presentations that stem from +the inspector and debugger are only valid as long as the corresponding +buffers are open. Using them later can cause errors or confusing +behavior. + +For some Lisp implementations you can also install the package +@code{slime-presentation-streams}, which enables presentations on the +Lisp @code{*standard-output*} stream and similar streams. This means +that not only results +of computations, but also some objects that are printed to the standard +output (as a side-effect of the computation) are associated with +presentations. Currently, all unreadable objects +and pathnames get printed as presentations. + +@example +CL-USER> (describe (find-class 'standard-object)) +@emph{#<STANDARD-CLASS STANDARD-OBJECT>} is an instance of + @emph{#<STANDARD-CLASS STANDARD-CLASS>}: + The following slots have :INSTANCE allocation: + PLIST NIL + FLAGS 1 + DIRECT-METHODS ((@emph{#<STANDARD-METHOD + SWANK::ALL-SLOTS-FOR-INSPECTOR + (STANDARD-OBJECT T)>} + ... +@end example + +Again, this makes it possible to inspect and copy-paste these objects. + +In addition to the standard Emacs commands, there are several keyboard +commands, a menu-bar menu, and a context menu to operate on +presentations. We describe the keyboard commands below; they are also +shown in the menu-bar menu. + +@table @kbd +@kbditem{C-c C-v SPC, slime-mark-presentation} +If point is within a presentation, move point to the beginning of the +presentation and mark to the end of the presentation. +This makes it possible to copy the presentation. + +@kbditem{C-c C-v w, slime-copy-presentation-at-point-to-kill-ring} +If point is within a presentation, copy the surrounding presentation +to the kill ring. + +@kbditem{C-c C-v r, slime-copy-presentation-at-point-to-repl} +If point is within a presentation, copy the surrounding presentation +to the REPL. + +@kbditem{C-c C-v d, slime-describe-presentation-at-point} +If point is within a presentation, describe the associated object. + +@kbditem{C-c C-v i, slime-inspect-presentation-at-point} +If point is within a presentation, inspect the associated object with +the SLIME inspector. + +@kbditem{C-c C-v n, slime-next-presentation} +Move point to the next presentation in the buffer. + +@kbditem{C-c C-v p, slime-previous-presentation} +Move point to the previous presentation in the buffer. -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 +Similar operations are also possible from the context menu of every +presentation. Using @kbd{mouse-3} on a presentation, the context menu +opens and offers various commands. For some objects, specialized +commands are also offered. Users can define additional specialized +commands by defining a method for +@code{swank::menu-choices-for-presentation}. + + +@strong{Warning:} On Lisp implementations without weak hash tables, +all objects associated with presentations are protected from garbage +collection. If your Lisp image grows too large because of that, +use @kbd{C-c C-v M-o} (@code{slime-clear-presentations}) to remove these +associations. You can also use the command @kbd{C-c M-o} +(@code{slime-repl-clear-buffer}), which both clears the REPL buffer and +removes all associations of objects with presentations. + +@strong{Warning:} Presentations can confuse new users. + +@example +CL-USER> (cons 1 2) +@emph{(1 . 2)} +CL-USER> (eq '@emph{(1 . 2)} '@emph{(1 . 2)}) +@emph{T} +@end example + +One could have expected @code{NIL} here, because it looks like two +fresh cons cells are compared regarding object identity. +However, in the example the presentation @code{@emph{(1 . 2)}} was copied twice +to the REPL. Thus @code{EQ} is really invoked with the same object, +namely the cons cell that was returned by the first form entered in the +REPL. @node Typeout frames @section Typeout frames Modified: branches/trunk-reorg/thirdparty/slime/slime.el ============================================================================== --- branches/trunk-reorg/thirdparty/slime/slime.el (original) +++ branches/trunk-reorg/thirdparty/slime/slime.el Mon Jan 28 06:47:40 2008 @@ -495,9 +495,9 @@ (t name)))) (format "%s" (read name)))) -(defun slime-pretty-current-package () - "Retrun a prettied version of `slime-current-package'." - (let ((p (slime-current-package))) +(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 @@ -1179,7 +1179,9 @@ (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)))) + (slime-start* (cond ((and command (symbolp command)) + (slime-lisp-options command)) + (t (slime-read-interactive-args)))))) (defvar slime-inferior-lisp-program-history '() "History list of command strings. Used by `slime'.") @@ -2695,10 +2697,11 @@ (when (< slime-repl-input-start-mark (point)) (set-marker slime-repl-input-start-mark (point)))))) -(defun slime-repl-emit-result (string) +(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) @@ -2873,7 +2876,8 @@ ("\C-c\C-w" slime-who-map) ("\C-\M-x" 'slime-eval-defun) ("\C-c\C-o" 'slime-repl-clear-output) - ("\C-c\C-t" 'slime-repl-clear-buffer) + ("\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) @@ -2945,14 +2949,11 @@ (when result (destructure-case result ((:values &rest strings) - (unless (bolp) (insert "\n")) (cond ((null strings) - (insert "; No value\n")) + (slime-repl-emit-result "; No value\n" t)) (t - (dolist (string strings) - (slime-propertize-region `(face slime-repl-result-face) - (insert string)) - (insert "\n"))))))) + (dolist (s strings) + (slime-repl-emit-result s t))))))) (slime-repl-insert-prompt))) (defun slime-repl-show-abort () @@ -3312,7 +3313,7 @@ (defun slime-repl-set-package (package) "Set the package of the REPL buffer to PACKAGE." (interactive (list (slime-read-package-name - "Package: " (slime-pretty-current-package)))) + "Package: " (slime-pretty-find-buffer-package)))) (with-current-buffer (slime-output-buffer) (let ((unfinished-input (slime-repl-current-input))) (destructuring-bind (name prompt-string) @@ -5868,7 +5869,8 @@ (defun slime-apropos (string &optional only-external-p package case-sensitive-p) - "Show all bound symbols whose names match STRING, a regular expression." + "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: ") @@ -5888,7 +5890,7 @@ (lambda (r) (slime-show-apropos r string package summary)))))) (defun slime-apropos-all () - "Shortcut for (slime-apropos <pattern> nil nil)" + "Shortcut for (slime-apropos <string> nil nil)" (interactive) (slime-apropos (read-string "SLIME Apropos: ") nil nil)) @@ -5931,10 +5933,7 @@ (dolist (plist plists) (let ((designator (plist-get plist :designator))) (assert designator) - (slime-insert-propertized (list 'face apropos-symbol-face - 'item designator - 'action 'slime-describe-symbol) - designator)) + (slime-insert-propertized `(face ,apropos-symbol-face) designator)) (terpri) (let ((apropos-label-properties slime-apropos-label-properties)) (loop for (prop namespace) @@ -6080,15 +6079,23 @@ (list 'slime-location location 'face 'font-lock-keyword-face) " " (slime-one-line-ify label)) - do (insert " - " (if (and (eql :location (car location)) - (assoc :file (cdr location))) - (second (assoc :file (cdr location))) - "file unknown") - "\n")))) + 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.") @@ -6287,9 +6294,7 @@ ("*SLIME macroexpansion*" :mode lisp-mode :reusep t) package (slime-macroexpansion-minor-mode) (erase-buffer) - (save-excursion - (insert expansion)) - (indent-sexp) + (insert expansion) (font-lock-fontify-buffer)))))) (defun slime-eval-macroexpand-inplace (expander) @@ -6318,59 +6323,7 @@ (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 @@ -6440,8 +6393,8 @@ (message "Connection closed."))) (defun slime-set-package (package) - (interactive (list (slime-read-package-name "Package: " - (slime-pretty-current-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) @@ -7105,6 +7058,8 @@ (destructuring-bind (start end) (sldb-frame-region) (list start end frame locals catches)))) +(defvar sldb-insert-frame-variable-value-function 'sldb-insert-frame-variable-value) + (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." @@ -7117,7 +7072,11 @@ (in-sldb-face local-name (concat name (if (zerop id) "" (format "#%d" id)))) " = ") - (insert (in-sldb-face local-value value) "\n"))))) + (funcall sldb-insert-frame-variable-value-function value frame i) + (insert "\n"))))) + +(defun sldb-insert-frame-variable-value (value frame index) + (insert (in-sldb-face local-value value))) (defun sldb-hide-frame-details () ;; delete locals and catch tags, but keep the function name and args. @@ -7329,19 +7288,17 @@ (defun slime-list-threads () "Display a list of threads." (interactive) - (slime-eval-async - '(swank:list-threads) - (lambda (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))))))) + (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) @@ -7550,6 +7507,8 @@ (defmacro slime-inspector-fontify (face string) `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) +(defvar slime-inspector-insert-ispec-function 'slime-inspector-insert-ispec) + (defun slime-open-inspector (inspected-parts &optional point) "Display INSPECTED-PARTS in a new inspector window. Optionally set point to POINT." @@ -7557,21 +7516,19 @@ (setq slime-buffer-connection (slime-current-connection)) (let ((inhibit-read-only t)) (erase-buffer) - (destructuring-bind (&key string-representation id title content) inspected-parts + (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 string-representation)) - (insert ":\n ") - (insert (fontify topline title)) + (insert title)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" (fontify label "--------------------") "\n") (save-excursion - (mapc #'slime-inspector-insert-ispec content)) + (mapc slime-inspector-insert-ispec-function content)) (pop-to-buffer (current-buffer)) (when point (check-type point cons) @@ -7870,7 +7827,6 @@ (def-slime-selector-method ?t "SLIME threads buffer." (slime-list-threads) - (slime-eval `(cl:quote nil)) ;wait until slime-list-threads returns "*slime-threads*") (defun slime-recently-visited-buffer (mode) @@ -8481,6 +8437,9 @@ (defun slime-wait-condition (name predicate timeout) (let ((end (time-add (current-time) (seconds-to-time timeout)))) (while (not (funcall predicate)) + (let ((now (current-time))) + (message "waiting for condition: %s [%s.%06d]" name + (format-time-string "%H:%M:%S" now) (third now))) (cond ((time-less-p end (current-time)) (error "Timeout waiting for condition: %S" name)) (t @@ -8666,7 +8625,10 @@ (cl-user::bar)) " - (cl-user::bar))) + (cl-user::bar)) + ("(defun foo () + #+#.'(:and) (/ 1 0))" + (/ 1 0))) (slime-check-top-level) (with-temp-buffer (lisp-mode) @@ -8698,9 +8660,9 @@ (sldb-quit) ;; Going down - enter another recursive debug ;; Recursively debug. - (slime-eval-async 'no-such-variable))))))) + (slime-eval-async '(error)))))))) (let ((sldb-hook (cons debug-hook sldb-hook))) - (slime-eval-async 'no-such-variable) + (slime-eval-async '(error)) (slime-sync-to-top-level 5) (slime-check-top-level) (slime-check ("Maximum depth reached (%S) is %S." @@ -9013,24 +8975,31 @@ (not (not (get-buffer-window (current-buffer))))))) (def-slime-test break - () + (times) "Test if BREAK invokes SLDB." - '(()) + '((1) (2) (3)) (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-compile-string + (prin1-to-string `(defun cl-user::foo () + (dotimes (i ,times) + (break) + (sleep 0.2)))) + 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) + (dotimes (i times) + (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 "sldb closed" + (lambda () (not (sldb-get-default-buffer))) + 0.2)) (slime-sync-to-top-level 5)) (def-slime-test interrupt-at-toplevel @@ -9129,21 +9098,6 @@ (list (nthcdr n seq)) (seq (> (length seq) n)))) -(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)) - ;;;;; Buffer related (defun slime-buffer-narrowed-p (&optional buffer) @@ -9241,6 +9195,32 @@ (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 Modified: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp Mon Jan 28 06:47:40 2008 @@ -157,6 +157,19 @@ (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) @@ -241,6 +254,210 @@ (defimplementation make-default-inspector () (make-instance 'ecl-inspector)) +(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) + ; ecl clos support leaves some to be desired + (cond + ((streamp o) + (values + (format nil "~S is an ordinary stream" o) + (append + (list + "Open for " + (cond + ((ignore-errors (interactive-stream-p o)) "Interactive") + ((and (input-stream-p o) (output-stream-p o)) "Input and output") + ((input-stream-p o) "Input") + ((output-stream-p o) "Output")) + `(:newline) `(:newline)) + (label-value-line* + ("Element type" (stream-element-type o)) + ("External format" (stream-external-format o))) + (ignore-errors (label-value-line* + ("Broadcast streams" (broadcast-stream-streams o)))) + (ignore-errors (label-value-line* + ("Concatenated streams" (concatenated-stream-streams o)))) + (ignore-errors (label-value-line* + ("Echo input stream" (echo-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Echo output stream" (echo-stream-output-stream o)))) + (ignore-errors (label-value-line* + ("Output String" (get-output-stream-string o)))) + (ignore-errors (label-value-line* + ("Synonym symbol" (synonym-stream-symbol o)))) + (ignore-errors (label-value-line* + ("Input stream" (two-way-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Output stream" (two-way-stream-output-stream o))))))) + (t + (let* ((cl (si:instance-class o)) + (slots (clos:class-slots cl))) + (values (format nil "~S is an instance of class ~A" + o (clos::class-name cl)) + (loop for x in slots append + (let* ((name (clos:slot-definition-name x)) + (value (clos::slot-value o name))) + (list + (format nil "~S: " name) + `(:value ,value) + `(:newline))))))))) + ;;;; 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*))) + + ) + Modified: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp Mon Jan 28 06:47:40 2008 @@ -236,8 +236,9 @@ (eql (mismatch "SB-" name) 3))) (defun sbcl-source-file-p (filename) - (loop for (_ pattern) in (logical-pathname-translations "SYS") - thereis (pathname-match-p filename pattern))) + (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) @@ -831,16 +832,19 @@ (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-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)))))) + (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) - (sb-c::debug-source-name (sb-di::code-location-debug-source 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 Modified: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp Mon Jan 28 06:47:40 2008 @@ -53,7 +53,8 @@ (check-type timeout (or null real)) (if (fboundp 'ext::stream-timeout) (setf (ext::stream-timeout stream) timeout) - (setf (slot-value (slot-value stream 'cl::stream) 'cl::timeout) timeout))) + (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout) + timeout))) ;;;;; Sockets @@ -87,7 +88,8 @@ :external-format external-format))) ;; Ignore character conversion errors. Without this the communication ;; channel is prone to lockup if a character conversion error occurs. - (setf (cl::stream-character-conversion-error-value stream) #\?) + (setf (lisp::character-conversion-stream-input-error-value stream) #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) #\?) stream)) Modified: branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank-source-path-parser.lisp Mon Jan 28 06:47:40 2008 @@ -56,20 +56,8 @@ (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 @@ -90,8 +78,7 @@ (let ((*read-suppress* t)) (dotimes (i n) (read stream))) - (let ((*read-suppress* nil) - (*read-eval* nil)) + (let ((*read-suppress* nil)) (read-and-record-source-map stream))) (defun source-path-stream-position (path stream) Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/slime/swank.lisp (original) +++ branches/trunk-reorg/thirdparty/slime/swank.lisp Mon Jan 28 06:47:40 2008 @@ -78,8 +78,7 @@ "Abbreviate dotted package names to their last component if T.") (defvar *swank-io-package* - (let ((package (or (find-package :swank-io-package) - (make-package :swank-io-package :use '())))) + (let ((package (make-package :swank-io-package :use '()))) (import '(nil t quote) package) package)) @@ -1582,7 +1581,7 @@ compound forms like lists or vectors.)" (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) (if found? - (values symbol nil) + (values symbol (length string) nil) (multiple-value-bind (sexp pos) (read-from-string string) (values sexp pos (when (symbolp sexp) @@ -2402,22 +2401,6 @@ (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 @@ -2984,11 +2967,10 @@ (let ((*print-pretty* nil) ; print everything in the same line (*print-circle* t) (*print-readably* nil)) - (multiple-value-bind (title content) (inspect-for-emacs object inspector) - (list :title title - :string-representation - (with-output-to-string (stream) - (print-unreadable-object (object stream :type t :identity t))) + (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)))))

1 0

[bknr-cvs] r2409 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 25 Jan '08

25 Jan '08

Author: ksprotte Date: Fri Jan 25 12:16:08 2008 New Revision: 2409 Modified: branches/bos/projects/bos/m2/geo-utm.lisp Log: added auto-generated note to geo-utm.lisp Modified: branches/bos/projects/bos/m2/geo-utm.lisp ============================================================================== --- branches/bos/projects/bos/m2/geo-utm.lisp (original) +++ branches/bos/projects/bos/m2/geo-utm.lisp Fri Jan 25 12:16:08 2008 @@ -1,5 +1,11 @@ (in-package :geo-utm) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; NOTE this file is mainly auto generated. +;; You should not edit it manually or you +;; might loose your changes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Converted from Javascript ;; Origin: http:;;home.hiwaay.net/~taylorc/toolbox/geography/geoutm.html

1 0

[bknr-cvs] r2408 - in branches/bos/projects/bos: m2 web
by ksprotte＠common-lisp.net 25 Jan '08

25 Jan '08

Author: ksprotte Date: Fri Jan 25 08:15:35 2008 New Revision: 2408 Modified: branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/web/kml-handlers.lisp Log: exporting contracts to GE now works with polygons + color 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 25 08:15:35 2008 @@ -113,6 +113,13 @@ (let ((m2 (apply #'get-m2 p))) (and m2 (eql contract (m2-contract m2)))))))) +(defun m2s-polygon-lon-lat (m2s) + (let ((polygon (m2s-polygon m2s))) + (mapcar (lambda (point) + (destructuring-bind (x y) point + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) + polygon))) + ;;;; SPONSOR ;;; Exportierte Funktionen: 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 25 08:15:35 2008 @@ -91,6 +91,8 @@ #:m2-utm-y #:m2-utm #:m2-lon-lat + #:m2s-polygon + #:m2s-polygon-lon-lat #:escape-nl #:return-m2s Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Fri Jan 25 08:15:35 2008 @@ -10,9 +10,12 @@ (setf max-y (max (m2-utm-y m2) (or max-y (m2-utm-y m2))))) (list min-x max-y max-x min-y))) -(defun points2string (points) +(defun kml-format-points (points) (format nil "~:{~F,~F,0 ~}" points)) +(defun kml-format-color (color &optional (opacity 255)) + (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color))) + (defclass contract-kml-handler (object-handler) ()) @@ -20,20 +23,24 @@ (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") ;; when name is xmlns, the attribute does not show up - why (?) ;; (attribute "xmlns" "http://earth.google.com/kml/2.2") - (destructuring-bind (left top right bottom) (contract-utm-bounding-box contract) + (let ((polygon (m2s-polygon-lon-lat (contract-m2s contract)))) (with-element "Document" (with-element "Placemark" (with-element "name" (format nil "contract~a" (store-object-id contract))) - (with-element "description" "a description") - (with-element "Polygon" + (with-element "description" "a description") + (with-element "Style" + (attribute "id" "#region") + (with-element "LineStyle" + (with-element "color" (text "ffff3500"))) + (with-element "PolyStyle" + (with-element "color" (text (kml-format-color (contract-color contract) 175))))) + (with-element "Polygon" + (with-element "styleUrl" "#region") (with-element "tessellate" (text "1")) (with-element "outerBoundaryIs" (with-element "LinearRing" (with-element "coordinates" - (text (points2string (list (geo-utm:utm-x-y-to-lon-lat left bottom +utm-zone+ t) - (geo-utm:utm-x-y-to-lon-lat right bottom +utm-zone+ t) - (geo-utm:utm-x-y-to-lon-lat right top +utm-zone+ t) - (geo-utm:utm-x-y-to-lon-lat left top +utm-zone+ t))))))))))))) + (text (kml-format-points polygon))))))))))) (defmethod handle-object ((handle-object contract-kml-handler) (object null) req) (error "Contract not found."))

1 0

[bknr-cvs] r2407 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 25 Jan '08

25 Jan '08

Author: ksprotte Date: Thu Jan 24 19:05:22 2008 New Revision: 2407 Modified: branches/bos/projects/bos/m2/geometry.lisp Log: point-to-polygon now much clearer and ... works Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Thu Jan 24 19:05:22 2008 @@ -90,8 +90,7 @@ (list (+ x dx) (+ y dy))))) - -;;; TODO eql for directions +;;; TODO add eql for directions ? (defun find-boundary-point (point in-region-p &optional (direction :up)) (let* ((direction (direction-as-list direction)) @@ -105,76 +104,51 @@ "Will return a closed path of points in mathematical order. IN-REGION-P is a predicate that takes a point as an argument. It defines the region whose bounding polygon is to be found." - (let (polygon (count 0)) + (let ((polygon) + (count 0) + (boundary-point (find-boundary-point point in-region-p :up)) + (initial-direction :left)) (labels ((neighbour (point direction) "Validate the NEIGHBOUR of POINT in DIRECTION, if it is part of the region, returns (NEIGHBOUR DIRECTION), - otherwise return NIL." + otherwise returns NIL." (when point (let ((neighbour (move point direction))) (when (funcall in-region-p neighbour) (list neighbour direction))))) - (diagonal-neighbour (point direction) - (case (direction-as-symbol direction) - (:left (neighbour (first (neighbour point direction)) :up)) - (:right (neighbour (first (neighbour point direction)) :down)) - (t nil))) (choose-next (point direction) + "Returns a place to move to next as a list (NEXT-POINT NEXT-DIRECTION). + NEXT-POINT can be the same POINT (but then with a different direction." (acond ((neighbour point (turn-right direction)) it) + ((neighbour (first (neighbour point direction)) + (turn-right direction)) + it) ((neighbour point direction) it) - ((neighbour point (turn-left direction)) it) - ((neighbour point (turn-left (turn-left direction))) it))) - (terminate (point end-point) - (when (equal point end-point) + (t (list point (turn-left direction))))) + (terminate (point direction) + "Are we done?" + (when (and (eql direction initial-direction) + (equal point boundary-point)) (incf count) - (= 2 count))) - (left-down-p (direction) - (member (direction-as-symbol direction) '(:left :down))) - (category-change-p (direction new-direction) - (arnesi:xor (left-down-p direction) - (left-down-p new-direction))) - (traverse (point direction end-point) - (unless (terminate point end-point) - (aif (diagonal-neighbour point direction) - ;; diagonal swap - (destructuring-bind (point direction) - it - (traverse point direction end-point)) - (destructuring-bind (x y) point - (destructuring-bind (next-point next-direction) - (choose-next point direction) - ;; push - (if (left-down-p direction) - (push point polygon) - (push (list (1+ x) (1+ y)) polygon)) - (when (and (category-change-p direction next-direction) - (left-down-p direction)) - (push (list x (1+ y)) polygon) - (push (list (1+ x) (1+ y)) polygon)) - (when (and (category-change-p direction next-direction) - (not (left-down-p direction))) - (push (list (1+ x) y) polygon) - (push (list x y) polygon)) - ;; print - (print (list point (direction-as-symbol direction))) - ;; traverse - (traverse next-point next-direction end-point))))))) - (let ((boundary-point (find-boundary-point point in-region-p :up)) - (initial-direction (direction-as-list :left))) - (destructuring-bind (&optional next-point next-direction) - (choose-next boundary-point initial-direction) - (declare (ignore next-direction)) - (cond - ((null next-point) - ;; single m2 case - (destructuring-bind (x y) - point - (list (list x y) - (list x (1+ y)) - (list (1+ x) (1+ y)) - (list (1+ x) y) - (list x y)))) - (t (traverse boundary-point initial-direction next-point) - (nreverse polygon)))))))) + (= 2 count))) + (push-point (point direction) + "Add a point to POLYGON. The actual point + depends on the DIRECTION." + (push + (case direction + (:left point) + (:down (move point :down)) + (:right (move (move point :down) :right)) + (:up (move point :right))) + polygon)) + (traverse (point direction) + "Go to next POINT by DIRECTION." + (push-point point direction) + (unless (terminate point direction) + (destructuring-bind (next-point next-direction) + (choose-next point direction) + (traverse next-point next-direction))))) + (traverse boundary-point initial-direction) + (nreverse polygon))))

1 0

[bknr-cvs] r2406 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 24 Jan '08

24 Jan '08

Author: ksprotte Date: Thu Jan 24 17:59:58 2008 New Revision: 2406 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/m2.lisp Log: just another backup for geometry in progress -- sorry Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Thu Jan 24 17:59:58 2008 @@ -90,15 +90,8 @@ (list (+ x dx) (+ y dy))))) -;;; polygon-from-m2s -;; (defun find-m2-by-min-x-y (m2s) -;; (iter -;; (for m2 in m2s) -;; (for x = (m2-x m2)) -;; (for y = (m2-y m2)) -;; (minimizing x into min-x) -;; (minimizing y into min-y) -;; (finally (return (get-m2 min-x min-y))))) + +;;; TODO eql for directions (defun find-boundary-point (point in-region-p &optional (direction :up)) (let* ((direction (direction-as-list direction)) @@ -107,7 +100,6 @@ (find-boundary-point next in-region-p) point))) - ;;; region-to-polygon (defun region-to-polygon (point in-region-p) "Will return a closed path of points in mathematical order. @@ -118,9 +110,15 @@ "Validate the NEIGHBOUR of POINT in DIRECTION, if it is part of the region, returns (NEIGHBOUR DIRECTION), otherwise return NIL." - (let ((neighbour (move point direction))) - (when (funcall in-region-p neighbour) - (list neighbour direction)))) + (when point + (let ((neighbour (move point direction))) + (when (funcall in-region-p neighbour) + (list neighbour direction))))) + (diagonal-neighbour (point direction) + (case (direction-as-symbol direction) + (:left (neighbour (first (neighbour point direction)) :up)) + (:right (neighbour (first (neighbour point direction)) :down)) + (t nil))) (choose-next (point direction) (acond ((neighbour point (turn-right direction)) it) @@ -135,32 +133,37 @@ (member (direction-as-symbol direction) '(:left :down))) (category-change-p (direction new-direction) (arnesi:xor (left-down-p direction) - (left-down-p new-direction))) + (left-down-p new-direction))) (traverse (point direction end-point) (unless (terminate point end-point) - (destructuring-bind (x y) - point - (destructuring-bind (next-point next-direction) - (choose-next point direction) - ;; push - (if (left-down-p direction) - (push point polygon) - (push (list (1+ x) (1+ y)) polygon)) - (when (and (category-change-p direction next-direction) - (left-down-p direction)) - (push (list x (1+ y)) polygon) - (push (list (1+ x) (1+ y)) polygon)) - (when (and (category-change-p direction next-direction) - (not (left-down-p direction))) - (push (list (1+ x) y) polygon) - (push (list x y) polygon)) - ;; print - (print (list point (direction-as-symbol direction))) - ;; traverse - (traverse next-point next-direction end-point)))))) - (let ((boundary-point (find-boundary-point point in-region-p :up))) + (aif (diagonal-neighbour point direction) + ;; diagonal swap + (destructuring-bind (point direction) + it + (traverse point direction end-point)) + (destructuring-bind (x y) point + (destructuring-bind (next-point next-direction) + (choose-next point direction) + ;; push + (if (left-down-p direction) + (push point polygon) + (push (list (1+ x) (1+ y)) polygon)) + (when (and (category-change-p direction next-direction) + (left-down-p direction)) + (push (list x (1+ y)) polygon) + (push (list (1+ x) (1+ y)) polygon)) + (when (and (category-change-p direction next-direction) + (not (left-down-p direction))) + (push (list (1+ x) y) polygon) + (push (list x y) polygon)) + ;; print + (print (list point (direction-as-symbol direction))) + ;; traverse + (traverse next-point next-direction end-point))))))) + (let ((boundary-point (find-boundary-point point in-region-p :up)) + (initial-direction (direction-as-list :left))) (destructuring-bind (&optional next-point next-direction) - (choose-next boundary-point (direction-as-list :left)) + (choose-next boundary-point initial-direction) (declare (ignore next-direction)) (cond ((null next-point) @@ -172,6 +175,6 @@ (list (1+ x) (1+ y)) (list (1+ x) y) (list x y)))) - (t (traverse boundary-point (direction-as-list :up) next-point) + (t (traverse boundary-point initial-direction next-point) (nreverse polygon)))))))) Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Thu Jan 24 17:59:58 2008 @@ -511,8 +511,9 @@ top (min top y) bottom (max bottom y)))) (values left top (- right left) (- bottom top))))) - (multiple-value-bind (LEFT TOP WIDTH HEIGHT) + (multiple-value-bind (left top width height) (compute-bounding-box m2s) + (declare (ignore width height)) (finish-output) (flet ((transform-x (x) (+ 30 (* 30 (- x left)))) @@ -524,7 +525,7 @@ (loop for m2 in m2s for x = (transform-x (m2-x m2)) for y = (transform-y (m2-y m2)) - do (ltk:create-text canvas (+ 10 x) (+ 10 y) "X")) + do (ltk:create-text canvas (+ 10 x) (+ 10 y) "x")) ;; draw polygon (loop for a in points for b in (cdr points)

1 0

[bknr-cvs] r2405 - in branches/bos/projects/bos: m2 payment-website/templates/de
by hhubner＠common-lisp.net 24 Jan '08

24 Jan '08

Author: hhubner Date: Thu Jan 24 16:18:58 2008 New Revision: 2405 Modified: branches/bos/projects/bos/m2/mail-generator.lisp branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml Log: Add printed certificate opt-out to manual transfer. 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 Thu Jan 24 16:18:58 2008 @@ -294,7 +294,7 @@ (mail-contract-data contract "Manually entered sponsor" parts)))) (defun mail-manual-sponsor-data (req) - (with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly) + (with-query-params (req contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (sponsor-id (store-object-id (contract-sponsor contract))) (parts (list (make-html-part (format nil " @@ -311,9 +311,10 @@ <tr><td>Postcode</td><td>~@[~A~]</td></tr> <tr><td>City</td><td>~@[~A~]</td></tr> <tr><td>Email</td><td>~@[~A~]</td></tr> - <tr><td>Phone</td><td>~@[~A~]</td></tr>~@[ + <tr><td>Phone</td><td>~@[~A~]</td></tr> <tr><td></td></tr> - <tr><td>Donation receipt at year's end</td><td>~A</td></tr>~] + <tr><td>Printed certificate</td><td>~A</td></tr> + <tr><td>Donation receipt at year's end</td><td>~A</td></tr> </table> <p><a href=\"~A/complete-transfer/~A?email=~A\">Acknowledge receipt of payment</a></p> </body> @@ -323,7 +324,8 @@ (length (contract-m2s contract)) (* 3.0 (length (contract-m2s contract))) vorname name strasse plz ort email telefon - (if donationcert-yearly "ja" "nein") + (if want-print "yes" "no") + (if donationcert-yearly "yes" "no") *website-url* contract-id email)) (make-contract-xml-part contract-id (all-request-params req)) (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id Modified: branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml (original) +++ branches/bos/projects/bos/payment-website/templates/de/ueberweisung.xml Thu Jan 24 16:18:58 2008 @@ -71,9 +71,6 @@ <td colspan="3" height="7"> </td> </tr> <tr> - <td colspan="3" height="7"> </td> - </tr> - <tr> <td height="10">Vorname:</td> <td width="10"></td> <td><input name="vorname" type="text" size="25" maxlength="30" /></td> @@ -110,7 +107,16 @@ <td colspan="3" height="20"> </td> </tr> <tr> - <td align="right" colspan="3"> + <td colspan="3"> + <input type="checkbox" name="want-print"/> + Ich möchte meine Regenwaldurkunde per Post zugeschickt bekommen. + </td> + </tr> + <tr> + <td colspan="3" height="20"> </td> + </tr> + <tr> + <td align="right" colspan="3"> <input type="submit" class="form_big" name="action" value="Angaben an BOS mailen" /> </td> </tr> @@ -123,11 +129,16 @@ <strong>[Persönliche Daten]</strong> <br /> Wir reservieren gerne die von Ihnen gewünschten m². Für die Zusendung -der entsprechenden Informationen (Regenwaldurkunde, Sponsorenprofil, -Geokoordinaten, Spendenbescheinigung) benötigen wir unbedingt die -Angabe Ihrer Daten. Nach erfolgter Überweisung erhalten Sie diese -Informationen schriftlich oder per E-Mail von uns. - <br /><br /><br /> +der entsprechenden Informationen (Regenwaldurkunde, Geokoordinaten, +Spendenbescheinigung) benötigen wir Ihre Daten. Nach +erfolgter Überweisung melden wir uns schriftlich und +per E-Mail. + <br /><br /> + <strong>[Urkunde]</strong> + <br /> + Sie können Ihre Regenwaldurkunde in jedem Fall als PDF von unserem System herunterladen, auch + wenn Sie es nicht per Post zugeschickt bekommen möchten. + <br /><br /> <strong>[Dieses Formular]</strong> <br /> Bitte senden Sie dieses Formular per E-Mail direkt an uns. Sie können es auch

1 0